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-2005 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Exp_Ch7;  use Exp_Ch7;
  34 with Exp_Tss;  use Exp_Tss;
  35 with Exp_Util; use Exp_Util;
  36 with Itypes;   use Itypes;
  37 with Nlists;   use Nlists;
  38 with Nmake;    use Nmake;
  39 with Namet;    use Namet;
  40 with Opt;      use Opt;
  41 with Output;   use Output;
  42 with Rtsfind;  use Rtsfind;
  43 with Sem;      use Sem;
  44 with Sem_Disp; use Sem_Disp;
  45 with Sem_Res;  use Sem_Res;
  46 with Sem_Type; use Sem_Type;
  47 with Sem_Util; use Sem_Util;
  48 with Sinfo;    use Sinfo;
  49 with Snames;   use Snames;
  50 with Stand;    use Stand;
  51 with Tbuild;   use Tbuild;
  52 with Ttypes;   use Ttypes;
  53 with Uintp;    use Uintp;
  54
  55 package body Exp_Disp is
  56
  57    Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
  58       (CW_Membership           => RE_CW_Membership,
  59        IW_Membership           => RE_IW_Membership,
  60        DT_Entry_Size           => RE_DT_Entry_Size,
  61        DT_Prologue_Size        => RE_DT_Prologue_Size,
  62        Get_Access_Level        => RE_Get_Access_Level,
  63        Get_External_Tag        => RE_Get_External_Tag,
  64        Get_Prim_Op_Address     => RE_Get_Prim_Op_Address,
  65        Get_RC_Offset           => RE_Get_RC_Offset,
  66        Get_Remotely_Callable   => RE_Get_Remotely_Callable,
  67        Inherit_DT              => RE_Inherit_DT,
  68        Inherit_TSD             => RE_Inherit_TSD,
  69        Register_Interface_Tag  => RE_Register_Interface_Tag,
  70        Register_Tag            => RE_Register_Tag,
  71        Set_Access_Level        => RE_Set_Access_Level,
  72        Set_Expanded_Name       => RE_Set_Expanded_Name,
  73        Set_External_Tag        => RE_Set_External_Tag,
  74        Set_Prim_Op_Address     => RE_Set_Prim_Op_Address,
  75        Set_RC_Offset           => RE_Set_RC_Offset,
  76        Set_Remotely_Callable   => RE_Set_Remotely_Callable,
  77        Set_TSD                 => RE_Set_TSD,
  78        TSD_Entry_Size          => RE_TSD_Entry_Size,
  79        TSD_Prologue_Size       => RE_TSD_Prologue_Size);
  80
  81    Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
  82       (CW_Membership           => False,
  83        IW_Membership           => False,
  84        DT_Entry_Size           => False,
  85        DT_Prologue_Size        => False,
  86        Get_Access_Level        => False,
  87        Get_External_Tag        => False,
  88        Get_Prim_Op_Address     => False,
  89        Get_Remotely_Callable   => False,
  90        Get_RC_Offset           => False,
  91        Inherit_DT              => True,
  92        Inherit_TSD             => True,
  93        Register_Interface_Tag  => True,
  94        Register_Tag            => True,
  95        Set_Access_Level        => True,
  96        Set_Expanded_Name       => True,
  97        Set_External_Tag        => True,
  98        Set_Prim_Op_Address     => True,
  99        Set_RC_Offset           => True,
 100        Set_Remotely_Callable   => True,
 101        Set_TSD                 => True,
 102        TSD_Entry_Size          => False,
 103        TSD_Prologue_Size       => False);
 104
 105    Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
 106       (CW_Membership           => 2,
 107        IW_Membership           => 2,
 108        DT_Entry_Size           => 0,
 109        DT_Prologue_Size        => 0,
 110        Get_Access_Level        => 1,
 111        Get_External_Tag        => 1,
 112        Get_Prim_Op_Address     => 2,
 113        Get_RC_Offset           => 1,
 114        Get_Remotely_Callable   => 1,
 115        Inherit_DT              => 3,
 116        Inherit_TSD             => 2,
 117        Register_Interface_Tag  => 2,
 118        Register_Tag            => 1,
 119        Set_Access_Level        => 2,
 120        Set_Expanded_Name       => 2,
 121        Set_External_Tag        => 2,
 122        Set_Prim_Op_Address     => 3,
 123        Set_RC_Offset           => 2,
 124        Set_Remotely_Callable   => 2,
 125        Set_TSD                 => 2,
 126        TSD_Entry_Size          => 0,
 127        TSD_Prologue_Size       => 0);
 128
 129    function Build_Anonymous_Access_Type
 130      (Directly_Designated_Type : Entity_Id;
 131       Related_Nod              : Node_Id) return Entity_Id;
 132    --  Returns a decorated entity corresponding with an anonymous access type.
 133    --  Used to generate unchecked type conversion of an address.
 134
 135    procedure Collect_All_Interfaces (T : Entity_Id);
 136    --  Ada 2005 (AI-251): Collect the whole list of interfaces that are
 137    --  directly or indirectly implemented by T. Used to compute the size
 138    --  of the table of interfaces.
 139
 140    function Default_Prim_Op_Position (Subp : Entity_Id) return Uint;
 141    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
 142    --  of the default primitive operations.
 143
 144    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
 145    --  Check if the type has a private view or if the public view appears
 146    --  in the visible part of a package spec.
 147
 148    ----------------------------------
 149    --  Build_Anonymous_Access_Type --
 150    ----------------------------------
 151
 152    function Build_Anonymous_Access_Type
 153      (Directly_Designated_Type : Entity_Id;
 154       Related_Nod              : Node_Id) return Entity_Id
 155    is
 156       New_E : Entity_Id;
 157
 158    begin
 159       New_E := Create_Itype (Ekind       => E_Anonymous_Access_Type,
 160                              Related_Nod => Related_Nod,
 161                              Scope_Id    => Current_Scope);
 162
 163       Set_Etype                    (New_E, New_E);
 164       Init_Size_Align              (New_E);
 165       Init_Size                    (New_E, System_Address_Size);
 166       Set_Directly_Designated_Type (New_E, Directly_Designated_Type);
 167       Set_Is_First_Subtype         (New_E);
 168
 169       return New_E;
 170    end Build_Anonymous_Access_Type;
 171
 172    ----------------------------
 173    -- Collect_All_Interfaces --
 174    ----------------------------
 175
 176    procedure Collect_All_Interfaces (T : Entity_Id) is
 177
 178       procedure Add_Interface (Iface : Entity_Id);
 179       --  Add the interface it if is not already in the list
 180
 181       procedure Collect (Typ   : Entity_Id);
 182       --  Subsidiary subprogram used to traverse the whole list
 183       --  of directly and indirectly implemented interfaces
 184
 185       -------------------
 186       -- Add_Interface --
 187       -------------------
 188
 189       procedure Add_Interface (Iface : Entity_Id) is
 190          Elmt  : Elmt_Id := First_Elmt (Abstract_Interfaces (T));
 191
 192       begin
 193          while Present (Elmt) and then Node (Elmt) /= Iface loop
 194             Next_Elmt (Elmt);
 195          end loop;
 196
 197          if not Present (Elmt) then
 198             Append_Elmt (Iface, Abstract_Interfaces (T));
 199          end if;
 200       end Add_Interface;
 201
 202       -------------
 203       -- Collect --
 204       -------------
 205
 206       procedure Collect (Typ : Entity_Id) is
 207          Nod      : constant Node_Id := Type_Definition (Parent (Typ));
 208          Id       : Node_Id;
 209          Iface    : Entity_Id;
 210          Ancestor : Entity_Id;
 211
 212       begin
 213          pragma Assert (False
 214             or else Nkind (Nod) = N_Derived_Type_Definition
 215             or else Nkind (Nod) = N_Record_Definition);
 216
 217          if Nkind (Nod) = N_Record_Definition then
 218             return;
 219          end if;
 220
 221          --  Include the ancestor if we are generating the whole list
 222          --  of interfaces. This is used to know the size of the table
 223          --  that stores the tag of all the ancestor interfaces.
 224
 225          Ancestor := Etype (Typ);
 226
 227          if Is_Interface (Ancestor) then
 228             Add_Interface (Ancestor);
 229          end if;
 230
 231          if Ancestor /= Typ
 232            and then Ekind (Ancestor) /= E_Record_Type_With_Private
 233          then
 234             Collect (Ancestor);
 235          end if;
 236
 237          --  Traverse the graph of ancestor interfaces
 238
 239          if Is_Non_Empty_List (Interface_List (Nod)) then
 240             Id := First (Interface_List (Nod));
 241
 242             while Present (Id) loop
 243
 244                Iface := Etype (Id);
 245
 246                if Is_Interface (Iface) then
 247                   Add_Interface (Iface);
 248                   Collect (Iface);
 249                end if;
 250
 251                Next (Id);
 252             end loop;
 253          end if;
 254       end Collect;
 255
 256    --  Start of processing for Collect_All_Interfaces
 257
 258    begin
 259       Collect (T);
 260    end Collect_All_Interfaces;
 261
 262    ------------------------------
 263    -- Default_Prim_Op_Position --
 264    ------------------------------
 265
 266    function Default_Prim_Op_Position (Subp : Entity_Id) return Uint is
 267       TSS_Name : TSS_Name_Type;
 268       E        : Entity_Id := Subp;
 269
 270    begin
 271       --  Handle overriden subprograms
 272
 273       while Present (Alias (E)) loop
 274          E := Alias (E);
 275       end loop;
 276
 277       Get_Name_String (Chars (E));
 278       TSS_Name :=
 279         TSS_Name_Type
 280           (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
 281
 282       if Chars (E) = Name_uSize then
 283          return Uint_1;
 284
 285       elsif Chars (E) = Name_uAlignment then
 286          return Uint_2;
 287
 288       elsif TSS_Name = TSS_Stream_Read then
 289          return Uint_3;
 290
 291       elsif TSS_Name = TSS_Stream_Write then
 292          return Uint_4;
 293
 294       elsif TSS_Name = TSS_Stream_Input then
 295          return Uint_5;
 296
 297       elsif TSS_Name = TSS_Stream_Output then
 298          return Uint_6;
 299
 300       elsif Chars (E) = Name_Op_Eq then
 301          return Uint_7;
 302
 303       elsif Chars (E) = Name_uAssign then
 304          return Uint_8;
 305
 306       elsif TSS_Name = TSS_Deep_Adjust then
 307          return Uint_9;
 308
 309       elsif TSS_Name = TSS_Deep_Finalize then
 310          return Uint_10;
 311
 312       else
 313          raise Program_Error;
 314       end if;
 315    end Default_Prim_Op_Position;
 316
 317    -----------------------------
 318    -- Expand_Dispatching_Call --
 319    -----------------------------
 320
 321    procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
 322       Loc      : constant Source_Ptr := Sloc (Call_Node);
 323       Call_Typ : constant Entity_Id  := Etype (Call_Node);
 324
 325       Ctrl_Arg   : constant Node_Id := Controlling_Argument (Call_Node);
 326       Param_List : constant List_Id := Parameter_Associations (Call_Node);
 327       Subp       : Entity_Id        := Entity (Name (Call_Node));
 328
 329       CW_Typ          : Entity_Id;
 330       New_Call        : Node_Id;
 331       New_Call_Name   : Node_Id;
 332       New_Params      : List_Id := No_List;
 333       Param           : Node_Id;
 334       Res_Typ         : Entity_Id;
 335       Subp_Ptr_Typ    : Entity_Id;
 336       Subp_Typ        : Entity_Id;
 337       Typ             : Entity_Id;
 338       Eq_Prim_Op      : Entity_Id := Empty;
 339       Controlling_Tag : Node_Id;
 340
 341       function New_Value (From : Node_Id) return Node_Id;
 342       --  From is the original Expression. New_Value is equivalent to a call
 343       --  to Duplicate_Subexpr with an explicit dereference when From is an
 344       --  access parameter.
 345
 346       function Controlling_Type (Subp : Entity_Id) return Entity_Id;
 347       --  Returns the tagged type for which Subp is a primitive subprogram
 348
 349       ---------------
 350       -- New_Value --
 351       ---------------
 352
 353       function New_Value (From : Node_Id) return Node_Id is
 354          Res : constant Node_Id := Duplicate_Subexpr (From);
 355       begin
 356          if Is_Access_Type (Etype (From)) then
 357             return Make_Explicit_Dereference (Sloc (From), Res);
 358          else
 359             return Res;
 360          end if;
 361       end New_Value;
 362
 363       ----------------------
 364       -- Controlling_Type --
 365       ----------------------
 366
 367       function Controlling_Type (Subp : Entity_Id) return Entity_Id is
 368       begin
 369          if Ekind (Subp) = E_Function
 370            and then Has_Controlling_Result (Subp)
 371          then
 372             return Base_Type (Etype (Subp));
 373
 374          else
 375             declare
 376                Formal : Entity_Id := First_Formal (Subp);
 377
 378             begin
 379                while Present (Formal) loop
 380                   if Is_Controlling_Formal (Formal) then
 381                      if Is_Access_Type (Etype (Formal)) then
 382                         return Base_Type (Designated_Type (Etype (Formal)));
 383                      else
 384                         return Base_Type (Etype (Formal));
 385                      end if;
 386                   end if;
 387
 388                   Next_Formal (Formal);
 389                end loop;
 390             end;
 391          end if;
 392
 393          --  Controlling type not found (should never happen)
 394
 395          return Empty;
 396       end Controlling_Type;
 397
 398    --  Start of processing for Expand_Dispatching_Call
 399
 400    begin
 401       --  If this is an inherited operation that was overridden, the body
 402       --  that is being called is its alias.
 403
 404       if Present (Alias (Subp))
 405         and then Is_Inherited_Operation (Subp)
 406         and then No (DTC_Entity (Subp))
 407       then
 408          Subp := Alias (Subp);
 409       end if;
 410
 411       --  Expand_Dispatching_Call is called directly from the semantics,
 412       --  so we need a check to see whether expansion is active before
 413       --  proceeding.
 414
 415       if not Expander_Active then
 416          return;
 417       end if;
 418
 419       --  Definition of the class-wide type and the tagged type
 420
 421       --  If the controlling argument is itself a tag rather than a tagged
 422       --  object, then use the class-wide type associated with the subprogram's
 423       --  controlling type. This case can occur when a call to an inherited
 424       --  primitive has an actual that originated from a default parameter
 425       --  given by a tag-indeterminate call and when there is no other
 426       --  controlling argument providing the tag (AI-239 requires dispatching).
 427       --  This capability of dispatching directly by tag is also needed by the
 428       --  implementation of AI-260 (for the generic dispatching constructors).
 429
 430       if Etype (Ctrl_Arg) = RTE (RE_Tag)
 431         or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)
 432       then
 433          CW_Typ := Class_Wide_Type (Controlling_Type (Subp));
 434
 435       elsif Is_Access_Type (Etype (Ctrl_Arg)) then
 436          CW_Typ := Designated_Type (Etype (Ctrl_Arg));
 437
 438       else
 439          CW_Typ := Etype (Ctrl_Arg);
 440       end if;
 441
 442       Typ := Root_Type (CW_Typ);
 443
 444       if not Is_Limited_Type (Typ) then
 445          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
 446       end if;
 447
 448       if Is_CPP_Class (Root_Type (Typ)) then
 449
 450          --  Create a new parameter list with the displaced 'this'
 451
 452          New_Params := New_List;
 453          Param := First_Actual (Call_Node);
 454          while Present (Param) loop
 455             Append_To (New_Params, Relocate_Node (Param));
 456             Next_Actual (Param);
 457          end loop;
 458
 459       elsif Present (Param_List) then
 460
 461          --  Generate the Tag checks when appropriate
 462
 463          New_Params := New_List;
 464
 465          Param := First_Actual (Call_Node);
 466          while Present (Param) loop
 467
 468             --  No tag check with itself
 469
 470             if Param = Ctrl_Arg then
 471                Append_To (New_Params,
 472                  Duplicate_Subexpr_Move_Checks (Param));
 473
 474             --  No tag check for parameter whose type is neither tagged nor
 475             --  access to tagged (for access parameters)
 476
 477             elsif No (Find_Controlling_Arg (Param)) then
 478                Append_To (New_Params, Relocate_Node (Param));
 479
 480             --  No tag check for function dispatching on result if the
 481             --  Tag given by the context is this one
 482
 483             elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
 484                Append_To (New_Params, Relocate_Node (Param));
 485
 486             --  "=" is the only dispatching operation allowed to get
 487             --  operands with incompatible tags (it just returns false).
 488             --  We use Duplicate_Subexpr_Move_Checks instead of calling
 489             --  Relocate_Node because the value will be duplicated to
 490             --  check the tags.
 491
 492             elsif Subp = Eq_Prim_Op then
 493                Append_To (New_Params,
 494                  Duplicate_Subexpr_Move_Checks (Param));
 495
 496             --  No check in presence of suppress flags
 497
 498             elsif Tag_Checks_Suppressed (Etype (Param))
 499               or else (Is_Access_Type (Etype (Param))
 500                          and then Tag_Checks_Suppressed
 501                                     (Designated_Type (Etype (Param))))
 502             then
 503                Append_To (New_Params, Relocate_Node (Param));
 504
 505             --  Optimization: no tag checks if the parameters are identical
 506
 507             elsif Is_Entity_Name (Param)
 508               and then Is_Entity_Name (Ctrl_Arg)
 509               and then Entity (Param) = Entity (Ctrl_Arg)
 510             then
 511                Append_To (New_Params, Relocate_Node (Param));
 512
 513             --  Now we need to generate the Tag check
 514
 515             else
 516                --  Generate code for tag equality check
 517                --  Perhaps should have Checks.Apply_Tag_Equality_Check???
 518
 519                Insert_Action (Ctrl_Arg,
 520                  Make_Implicit_If_Statement (Call_Node,
 521                    Condition =>
 522                      Make_Op_Ne (Loc,
 523                        Left_Opnd =>
 524                          Make_Selected_Component (Loc,
 525                            Prefix => New_Value (Ctrl_Arg),
 526                            Selector_Name =>
 527                              New_Reference_To
 528                                (First_Tag_Component (Typ), Loc)),
 529
 530                        Right_Opnd =>
 531                          Make_Selected_Component (Loc,
 532                            Prefix =>
 533                              Unchecked_Convert_To (Typ, New_Value (Param)),
 534                            Selector_Name =>
 535                              New_Reference_To
 536                                (First_Tag_Component (Typ), Loc))),
 537
 538                    Then_Statements =>
 539                      New_List (New_Constraint_Error (Loc))));
 540
 541                Append_To (New_Params, Relocate_Node (Param));
 542             end if;
 543
 544             Next_Actual (Param);
 545          end loop;
 546       end if;
 547
 548       --  Generate the appropriate subprogram pointer type
 549
 550       if  Etype (Subp) = Typ then
 551          Res_Typ := CW_Typ;
 552       else
 553          Res_Typ := Etype (Subp);
 554       end if;
 555
 556       Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
 557       Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
 558       Set_Etype          (Subp_Typ, Res_Typ);
 559       Init_Size_Align    (Subp_Ptr_Typ);
 560       Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
 561
 562       --  Create a new list of parameters which is a copy of the old formal
 563       --  list including the creation of a new set of matching entities.
 564
 565       declare
 566          Old_Formal : Entity_Id := First_Formal (Subp);
 567          New_Formal : Entity_Id;
 568          Extra      : Entity_Id;
 569
 570       begin
 571          if Present (Old_Formal) then
 572             New_Formal := New_Copy (Old_Formal);
 573             Set_First_Entity (Subp_Typ, New_Formal);
 574             Param := First_Actual (Call_Node);
 575
 576             loop
 577                Set_Scope (New_Formal, Subp_Typ);
 578
 579                --  Change all the controlling argument types to be class-wide
 580                --  to avoid a recursion in dispatching.
 581
 582                if Is_Controlling_Formal (New_Formal) then
 583                   Set_Etype (New_Formal, Etype (Param));
 584                end if;
 585
 586                if Is_Itype (Etype (New_Formal)) then
 587                   Extra := New_Copy (Etype (New_Formal));
 588
 589                   if Ekind (Extra) = E_Record_Subtype
 590                     or else Ekind (Extra) = E_Class_Wide_Subtype
 591                   then
 592                      Set_Cloned_Subtype (Extra, Etype (New_Formal));
 593                   end if;
 594
 595                   Set_Etype (New_Formal, Extra);
 596                   Set_Scope (Etype (New_Formal), Subp_Typ);
 597                end if;
 598
 599                Extra := New_Formal;
 600                Next_Formal (Old_Formal);
 601                exit when No (Old_Formal);
 602
 603                Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
 604                Next_Entity (New_Formal);
 605                Next_Actual (Param);
 606             end loop;
 607             Set_Last_Entity (Subp_Typ, Extra);
 608
 609             --  Copy extra formals
 610
 611             New_Formal := First_Entity (Subp_Typ);
 612             while Present (New_Formal) loop
 613                if Present (Extra_Constrained (New_Formal)) then
 614                   Set_Extra_Formal (Extra,
 615                     New_Copy (Extra_Constrained (New_Formal)));
 616                   Extra := Extra_Formal (Extra);
 617                   Set_Extra_Constrained (New_Formal, Extra);
 618
 619                elsif Present (Extra_Accessibility (New_Formal)) then
 620                   Set_Extra_Formal (Extra,
 621                     New_Copy (Extra_Accessibility (New_Formal)));
 622                   Extra := Extra_Formal (Extra);
 623                   Set_Extra_Accessibility (New_Formal, Extra);
 624                end if;
 625
 626                Next_Formal (New_Formal);
 627             end loop;
 628          end if;
 629       end;
 630
 631       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
 632       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
 633
 634       --  If the controlling argument is a value of type Ada.Tag then
 635       --  use it directly.  Otherwise, the tag must be extracted from
 636       --  the controlling object.
 637
 638       if Etype (Ctrl_Arg) = RTE (RE_Tag)
 639         or else Etype (Ctrl_Arg) = RTE (RE_Interface_Tag)
 640       then
 641          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
 642
 643       else
 644          Controlling_Tag :=
 645            Make_Selected_Component (Loc,
 646              Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
 647              Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
 648       end if;
 649
 650       --  Generate:
 651       --   Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
 652
 653       New_Call_Name :=
 654         Unchecked_Convert_To (Subp_Ptr_Typ,
 655           Make_DT_Access_Action (Typ,
 656             Action => Get_Prim_Op_Address,
 657             Args => New_List (
 658
 659             --  Vptr
 660
 661               Controlling_Tag,
 662
 663             --  Position
 664
 665               Make_Integer_Literal (Loc, DT_Position (Subp)))));
 666
 667       if Nkind (Call_Node) = N_Function_Call then
 668
 669          --  Ada 2005 (AI-251): A dispatching "=" with an abstract interface
 670          --  just requires the comparison of the tags.
 671
 672          if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type
 673            and then Is_Interface (Etype (Ctrl_Arg))
 674            and then Subp = Eq_Prim_Op
 675          then
 676             Param := First_Actual (Call_Node);
 677
 678             New_Call :=
 679                 Make_Op_Eq (Loc,
 680                    Left_Opnd =>
 681                      Make_Selected_Component (Loc,
 682                        Prefix => New_Value (Param),
 683                        Selector_Name =>
 684                          New_Reference_To (First_Tag_Component (Typ), Loc)),
 685
 686                    Right_Opnd =>
 687                      Make_Selected_Component (Loc,
 688                        Prefix =>
 689                          Unchecked_Convert_To (Typ,
 690                            New_Value (Next_Actual (Param))),
 691                        Selector_Name =>
 692                          New_Reference_To (First_Tag_Component (Typ), Loc)));
 693
 694          else
 695             New_Call :=
 696               Make_Function_Call (Loc,
 697                 Name => New_Call_Name,
 698                 Parameter_Associations => New_Params);
 699
 700             --  If this is a dispatching "=", we must first compare the tags so
 701             --  we generate: x.tag = y.tag and then x = y
 702
 703             if Subp = Eq_Prim_Op then
 704                Param := First_Actual (Call_Node);
 705                New_Call :=
 706                  Make_And_Then (Loc,
 707                    Left_Opnd =>
 708                         Make_Op_Eq (Loc,
 709                           Left_Opnd =>
 710                             Make_Selected_Component (Loc,
 711                               Prefix => New_Value (Param),
 712                               Selector_Name =>
 713                                 New_Reference_To (First_Tag_Component (Typ),
 714                                                   Loc)),
 715
 716                           Right_Opnd =>
 717                             Make_Selected_Component (Loc,
 718                               Prefix =>
 719                                 Unchecked_Convert_To (Typ,
 720                                   New_Value (Next_Actual (Param))),
 721                               Selector_Name =>
 722                                 New_Reference_To (First_Tag_Component (Typ),
 723                                                   Loc))),
 724                    Right_Opnd => New_Call);
 725             end if;
 726          end if;
 727
 728       else
 729          New_Call :=
 730            Make_Procedure_Call_Statement (Loc,
 731              Name => New_Call_Name,
 732              Parameter_Associations => New_Params);
 733       end if;
 734
 735       Rewrite (Call_Node, New_Call);
 736       Analyze_And_Resolve (Call_Node, Call_Typ);
 737    end Expand_Dispatching_Call;
 738
 739    ---------------------------------
 740    -- Expand_Interface_Conversion --
 741    ---------------------------------
 742
 743    procedure Expand_Interface_Conversion (N : Node_Id) is
 744       Loc         : constant Source_Ptr := Sloc (N);
 745       Operand     : constant Node_Id    := Expression (N);
 746       Operand_Typ : Entity_Id           := Etype (Operand);
 747       Target_Type : Entity_Id           := Etype (N);
 748       Iface_Tag   : Entity_Id;
 749
 750    begin
 751       pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
 752
 753       --  Ada 2005 (AI-345): Set Operand_Typ and Handle task interfaces
 754
 755       if Ekind (Operand_Typ) = E_Task_Type
 756         or else Ekind (Operand_Typ) = E_Protected_Type
 757       then
 758          Operand_Typ := Corresponding_Record_Type (Operand_Typ);
 759       end if;
 760
 761       if Is_Access_Type (Target_Type) then
 762          Target_Type := Etype (Directly_Designated_Type (Target_Type));
 763
 764       elsif Is_Class_Wide_Type (Target_Type) then
 765          Target_Type := Etype (Target_Type);
 766       end if;
 767
 768       pragma Assert (not Is_Class_Wide_Type (Target_Type)
 769         and then Is_Interface (Target_Type));
 770
 771       Iface_Tag := Find_Interface_Tag (Operand_Typ, Target_Type);
 772
 773       pragma Assert (Iface_Tag /= Empty);
 774
 775       Rewrite (N,
 776         Unchecked_Convert_To (Etype (N),
 777           Make_Attribute_Reference (Loc,
 778             Prefix => Make_Selected_Component (Loc,
 779                         Prefix => Relocate_Node (Expression (N)),
 780                         Selector_Name => New_Occurrence_Of (Iface_Tag, Loc)),
 781             Attribute_Name => Name_Address)));
 782
 783       Analyze (N);
 784    end Expand_Interface_Conversion;
 785
 786    ------------------------------
 787    -- Expand_Interface_Actuals --
 788    ------------------------------
 789
 790    procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
 791       Loc        : constant Source_Ptr := Sloc (Call_Node);
 792       Actual     : Node_Id;
 793       Actual_Typ : Entity_Id;
 794       Conversion : Node_Id;
 795       Formal     : Entity_Id;
 796       Formal_Typ : Entity_Id;
 797       Subp       : Entity_Id;
 798       Nam        : Name_Id;
 799
 800    begin
 801       --  This subprogram is called directly from the semantics, so we need a
 802       --  check to see whether expansion is active before proceeding.
 803
 804       if not Expander_Active then
 805          return;
 806       end if;
 807
 808       --  Call using access to subprogram with explicit dereference
 809
 810       if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
 811          Subp := Etype (Name (Call_Node));
 812
 813       --  Normal case
 814
 815       else
 816          Subp := Entity (Name (Call_Node));
 817       end if;
 818
 819       Formal := First_Formal (Subp);
 820       Actual := First_Actual (Call_Node);
 821
 822       while Present (Formal) loop
 823
 824          pragma Assert (Ekind (Etype (Etype (Formal)))
 825                         /= E_Record_Type_With_Private);
 826
 827          --  Ada 2005 (AI-251): Conversion to interface to force "this"
 828          --  displacement
 829
 830          Formal_Typ := Etype (Etype (Formal));
 831          Actual_Typ := Etype (Actual);
 832
 833          if Is_Interface (Formal_Typ) then
 834
 835             Conversion := Convert_To (Formal_Typ, New_Copy_Tree (Actual));
 836             Rewrite             (Actual, Conversion);
 837             Analyze_And_Resolve (Actual, Formal_Typ);
 838
 839             Rewrite (Actual,
 840               Make_Explicit_Dereference (Loc,
 841                 Unchecked_Convert_To
 842                   (Build_Anonymous_Access_Type (Formal_Typ, Call_Node),
 843                    Relocate_Node (Expression (Actual)))));
 844
 845             Analyze_And_Resolve (Actual, Formal_Typ);
 846
 847          --  Anonymous access type
 848
 849          elsif Is_Access_Type (Formal_Typ)
 850            and then Is_Interface (Etype
 851                                   (Directly_Designated_Type
 852                                    (Formal_Typ)))
 853            and then Interface_Present_In_Ancestor
 854                       (Typ   => Etype (Directly_Designated_Type
 855                                         (Actual_Typ)),
 856                        Iface => Etype (Directly_Designated_Type
 857                                         (Formal_Typ)))
 858          then
 859
 860             if Nkind (Actual) = N_Attribute_Reference
 861               and then
 862                (Attribute_Name (Actual) = Name_Access
 863                  or else Attribute_Name (Actual) = Name_Unchecked_Access)
 864             then
 865                Nam := Attribute_Name (Actual);
 866
 867                Conversion :=
 868                  Convert_To
 869                    (Etype (Directly_Designated_Type (Formal_Typ)),
 870                     Prefix (Actual));
 871
 872                Rewrite (Actual, Conversion);
 873
 874                Analyze_And_Resolve (Actual,
 875                  Etype (Directly_Designated_Type (Formal_Typ)));
 876
 877                Rewrite (Actual,
 878                  Unchecked_Convert_To (Formal_Typ,
 879                    Make_Attribute_Reference (Loc,
 880                      Prefix =>
 881                        Relocate_Node (Prefix (Expression (Actual))),
 882                      Attribute_Name => Nam)));
 883
 884                Analyze_And_Resolve (Actual, Formal_Typ);
 885
 886             else
 887                Conversion :=
 888                  Convert_To (Formal_Typ, New_Copy_Tree (Actual));
 889                Rewrite             (Actual, Conversion);
 890                Analyze_And_Resolve (Actual, Formal_Typ);
 891             end if;
 892          end if;
 893
 894          Next_Actual (Actual);
 895          Next_Formal (Formal);
 896       end loop;
 897    end Expand_Interface_Actuals;
 898
 899    ----------------------------
 900    -- Expand_Interface_Thunk --
 901    ----------------------------
 902
 903    function Expand_Interface_Thunk
 904      (N           : Node_Id;
 905       Thunk_Alias : Entity_Id;
 906       Thunk_Id    : Entity_Id;
 907       Iface_Tag   : Entity_Id) return Node_Id
 908    is
 909       Loc         : constant Source_Ptr := Sloc (N);
 910       Actuals     : constant List_Id    := New_List;
 911       Decl        : constant List_Id    := New_List;
 912       Formals     : constant List_Id    := New_List;
 913       Thunk_Tag   : constant Node_Id    := Iface_Tag;
 914       Target      : Entity_Id;
 915       New_Code    : Node_Id;
 916       Formal      : Node_Id;
 917       New_Formal  : Node_Id;
 918       Decl_1      : Node_Id;
 919       Decl_2      : Node_Id;
 920       Subtyp_Mark : Node_Id;
 921
 922    begin
 923
 924       --  Traverse the list of alias to find the final target
 925
 926       Target := Thunk_Alias;
 927
 928       while Present (Alias (Target)) loop
 929          Target := Alias (Target);
 930       end loop;
 931
 932       --  Duplicate the formals
 933
 934       Formal := First_Formal (Thunk_Alias);
 935
 936       while Present (Formal) loop
 937          New_Formal := Copy_Separate_Tree (Parent (Formal));
 938
 939          --  Handle the case in which the subprogram covering
 940          --  the interface has been inherited:
 941
 942          --  Example:
 943          --     type I is interface;
 944          --     procedure P (X : in I) is abstract;
 945
 946          --     type T is tagged null record;
 947          --     procedure P (X : T);
 948
 949          --     type DT is new T and I with ...
 950
 951          if Is_Controlling_Formal (Formal) then
 952             Set_Parameter_Type (New_Formal,
 953               New_Reference_To (Etype (First_Entity (N)), Loc));
 954          end if;
 955
 956          Append_To (Formals, New_Formal);
 957          Next_Formal (Formal);
 958       end loop;
 959
 960       if Ekind (First_Formal (Thunk_Alias)) = E_In_Parameter
 961         and then Ekind (Etype (First_Formal (Thunk_Alias)))
 962                   = E_Anonymous_Access_Type
 963       then
 964
 965          --  Generate:
 966
 967          --     type T is access all <<type of the first formal>>
 968          --     S1 := Storage_Offset!(First_formal)
 969          --           - Storage_Offset!(First_Formal.Thunk_Tag'Position)
 970
 971          --  ... and the first actual of the call is generated as T!(S1)
 972
 973          Decl_2 :=
 974            Make_Full_Type_Declaration (Loc,
 975              Defining_Identifier =>
 976                Make_Defining_Identifier (Loc,
 977                  New_Internal_Name ('T')),
 978              Type_Definition =>
 979                Make_Access_To_Object_Definition (Loc,
 980                  All_Present            => True,
 981                  Null_Exclusion_Present => False,
 982                  Constant_Present       => False,
 983                  Subtype_Indication     =>
 984                    New_Reference_To
 985                      (Directly_Designated_Type
 986                         (Etype (First_Formal (Thunk_Alias))), Loc)
 987                          ));
 988
 989          Decl_1 :=
 990            Make_Object_Declaration (Loc,
 991              Defining_Identifier =>
 992                Make_Defining_Identifier (Loc,
 993                  New_Internal_Name ('S')),
 994              Constant_Present    => True,
 995              Object_Definition   =>
 996                New_Reference_To (RTE (RE_Storage_Offset), Loc),
 997              Expression          =>
 998                Make_Op_Subtract (Loc,
 999                  Left_Opnd  =>
1000                    Unchecked_Convert_To
1001                      (RTE (RE_Storage_Offset),
1002                       New_Reference_To
1003                         (Defining_Identifier (First (Formals)), Loc)),
1004                   Right_Opnd =>
1005                     Unchecked_Convert_To
1006                       (RTE (RE_Storage_Offset),
1007                        Make_Attribute_Reference (Loc,
1008                          Prefix =>
1009                            Make_Selected_Component (Loc,
1010                              Prefix =>
1011                                New_Reference_To
1012                                  (Defining_Identifier (First (Formals)), Loc),
1013                              Selector_Name =>
1014                                New_Occurrence_Of (Thunk_Tag, Loc)),
1015                          Attribute_Name => Name_Position))));
1016
1017          Append_To (Decl, Decl_2);
1018          Append_To (Decl, Decl_1);
1019
1020          --  Reference the new first actual
1021
1022          Append_To (Actuals,
1023            Unchecked_Convert_To
1024              (Defining_Identifier (Decl_2),
1025               New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1026
1027          --  Side note: The reverse order of declarations is just to ensure
1028          --  that the call to RE_Print is correct.
1029
1030       else
1031          --  Generate:
1032          --
1033          --     S1 := Storage_Offset!(First_formal'Address)
1034          --           - Storage_Offset!(First_Formal.Thunk_Tag'Position)
1035          --     S2 := Tag_Ptr!(S3)
1036
1037          Decl_1 :=
1038            Make_Object_Declaration (Loc,
1039              Defining_Identifier =>
1040                Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1041              Constant_Present    => True,
1042              Object_Definition   =>
1043                New_Reference_To (RTE (RE_Storage_Offset), Loc),
1044              Expression          =>
1045                Make_Op_Subtract (Loc,
1046                  Left_Opnd =>
1047                    Unchecked_Convert_To
1048                      (RTE (RE_Storage_Offset),
1049                       Make_Attribute_Reference (Loc,
1050                         Prefix =>
1051                           New_Reference_To
1052                             (Defining_Identifier (First (Formals)), Loc),
1053                         Attribute_Name => Name_Address)),
1054                  Right_Opnd =>
1055                    Unchecked_Convert_To
1056                      (RTE (RE_Storage_Offset),
1057                       Make_Attribute_Reference (Loc,
1058                         Prefix =>
1059                           Make_Selected_Component (Loc,
1060                             Prefix =>
1061                               New_Reference_To
1062                                 (Defining_Identifier (First (Formals)), Loc),
1063                                  Selector_Name =>
1064                                    New_Occurrence_Of (Thunk_Tag, Loc)),
1065                         Attribute_Name => Name_Position))));
1066
1067          Decl_2 :=
1068            Make_Object_Declaration (Loc,
1069              Defining_Identifier =>
1070                Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1071              Constant_Present    => True,
1072              Object_Definition   => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1073              Expression          =>
1074                Unchecked_Convert_To
1075                  (RTE (RE_Addr_Ptr),
1076                   New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1077
1078          Append_To (Decl, Decl_1);
1079          Append_To (Decl, Decl_2);
1080
1081          --  Reference the new first actual
1082
1083          Append_To (Actuals,
1084            Unchecked_Convert_To
1085              (Etype (First_Entity (Target)),
1086               Make_Explicit_Dereference (Loc,
1087                 New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1088
1089       end if;
1090
1091       Formal := Next (First (Formals));
1092       while Present (Formal) loop
1093          Append_To (Actuals,
1094             New_Reference_To (Defining_Identifier (Formal), Loc));
1095          Next (Formal);
1096       end loop;
1097
1098       if Ekind (Thunk_Alias) = E_Procedure then
1099          New_Code :=
1100            Make_Subprogram_Body (Loc,
1101               Specification =>
1102                 Make_Procedure_Specification (Loc,
1103                   Defining_Unit_Name       => Thunk_Id,
1104                   Parameter_Specifications => Formals),
1105               Declarations => Decl,
1106               Handled_Statement_Sequence =>
1107                 Make_Handled_Sequence_Of_Statements (Loc,
1108                   Statements => New_List (
1109                     Make_Procedure_Call_Statement (Loc,
1110                        Name => New_Occurrence_Of (Target, Loc),
1111                        Parameter_Associations => Actuals))));
1112
1113       else pragma Assert (Ekind (Thunk_Alias) = E_Function);
1114
1115          if not Present (Alias (Thunk_Alias)) then
1116             Subtyp_Mark := Subtype_Mark (Parent (Thunk_Alias));
1117          else
1118             --  The last element in the alias list has the correct subtype_mark
1119             --  of the function result
1120
1121             declare
1122                E : Entity_Id := Alias (Thunk_Alias);
1123             begin
1124                while Present (Alias (E)) loop
1125                   E := Alias (E);
1126                end loop;
1127                Subtyp_Mark := Subtype_Mark (Parent (E));
1128             end;
1129          end if;
1130
1131          New_Code :=
1132            Make_Subprogram_Body (Loc,
1133               Specification =>
1134                 Make_Function_Specification (Loc,
1135                   Defining_Unit_Name       => Thunk_Id,
1136                   Parameter_Specifications => Formals,
1137                   Subtype_Mark => New_Copy (Subtyp_Mark)),
1138               Declarations => Decl,
1139               Handled_Statement_Sequence =>
1140                 Make_Handled_Sequence_Of_Statements (Loc,
1141                   Statements => New_List (
1142                     Make_Return_Statement (Loc,
1143                       Make_Function_Call (Loc,
1144                         Name => New_Occurrence_Of (Target, Loc),
1145                         Parameter_Associations => Actuals)))));
1146       end if;
1147
1148       Analyze (New_Code);
1149       return New_Code;
1150    end Expand_Interface_Thunk;
1151
1152    -------------------
1153    -- Fill_DT_Entry --
1154    -------------------
1155
1156    function Fill_DT_Entry
1157      (Loc     : Source_Ptr;
1158       Prim    : Entity_Id) return Node_Id
1159    is
1160       Typ     : constant Entity_Id := Scope (DTC_Entity (Prim));
1161       DT_Ptr  : constant Entity_Id :=
1162                   Node (First_Elmt (Access_Disp_Table (Typ)));
1163       Pos     : constant Uint      := DT_Position (Prim);
1164       Tag     : constant Entity_Id := First_Tag_Component (Typ);
1165
1166    begin
1167       if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
1168          raise Program_Error;
1169       end if;
1170
1171       return
1172         Make_DT_Access_Action (Typ,
1173           Action => Set_Prim_Op_Address,
1174           Args   => New_List (
1175             Unchecked_Convert_To (RTE (RE_Tag),
1176               New_Reference_To (DT_Ptr, Loc)),                  -- DTptr
1177
1178             Make_Integer_Literal (Loc, Pos),                    -- Position
1179
1180             Make_Attribute_Reference (Loc,                      -- Value
1181               Prefix          => New_Reference_To (Prim, Loc),
1182               Attribute_Name  => Name_Address)));
1183    end Fill_DT_Entry;
1184
1185    -----------------------------
1186    -- Fill_Secondary_DT_Entry --
1187    -----------------------------
1188
1189    function Fill_Secondary_DT_Entry
1190      (Loc          : Source_Ptr;
1191       Prim         : Entity_Id;
1192       Thunk_Id     : Entity_Id;
1193       Iface_DT_Ptr : Entity_Id) return Node_Id
1194    is
1195       Typ        : constant Entity_Id := Scope (DTC_Entity (Alias (Prim)));
1196       Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim);
1197       Pos        : constant Uint      := DT_Position (Iface_Prim);
1198       Tag        : constant Entity_Id :=
1199                      First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
1200
1201    begin
1202       if Pos = Uint_0 or else Pos > DT_Entry_Count (Tag) then
1203          raise Program_Error;
1204       end if;
1205
1206       return
1207         Make_DT_Access_Action (Typ,
1208           Action => Set_Prim_Op_Address,
1209           Args   => New_List (
1210             Unchecked_Convert_To (RTE (RE_Tag),
1211               New_Reference_To (Iface_DT_Ptr, Loc)),            -- DTptr
1212
1213             Make_Integer_Literal (Loc, Pos),                    -- Position
1214
1215             Make_Attribute_Reference (Loc,                      -- Value
1216               Prefix          => New_Reference_To (Thunk_Id, Loc),
1217               Attribute_Name  => Name_Address)));
1218    end Fill_Secondary_DT_Entry;
1219
1220    ---------------------------
1221    -- Get_Remotely_Callable --
1222    ---------------------------
1223
1224    function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
1225       Loc : constant Source_Ptr := Sloc (Obj);
1226
1227    begin
1228       return Make_DT_Access_Action
1229         (Typ    => Etype (Obj),
1230          Action => Get_Remotely_Callable,
1231          Args   => New_List (
1232            Make_Selected_Component (Loc,
1233              Prefix        => Obj,
1234              Selector_Name => Make_Identifier (Loc, Name_uTag))));
1235    end Get_Remotely_Callable;
1236
1237    -------------
1238    -- Make_DT --
1239    -------------
1240
1241    function Make_DT (Typ : Entity_Id) return List_Id is
1242       Loc         : constant Source_Ptr := Sloc (Typ);
1243       Result      : constant List_Id    := New_List;
1244       Elab_Code   : constant List_Id    := New_List;
1245
1246       Tname       : constant Name_Id := Chars (Typ);
1247       Name_DT     : constant Name_Id := New_External_Name (Tname, 'T');
1248       Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
1249       Name_TSD    : constant Name_Id := New_External_Name (Tname, 'B');
1250       Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
1251       Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
1252
1253       DT     : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
1254       DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
1255       TSD    : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
1256       Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
1257       No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
1258
1259       Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
1260       I_Depth         : Int;
1261       Size_Expr_Node  : Node_Id;
1262       Old_Tag1        : Node_Id;
1263       Old_Tag2        : Node_Id;
1264       Num_Ifaces      : Int;
1265       Nb_Prim         : Int;
1266       TSD_Num_Entries : Int;
1267       Typ_Copy        : constant Entity_Id := New_Copy (Typ);
1268       AI              : Elmt_Id;
1269
1270    begin
1271       if not RTE_Available (RE_Tag) then
1272          Error_Msg_CRT ("tagged types", Typ);
1273          return New_List;
1274       end if;
1275
1276       --  Collect the full list of directly and indirectly implemented
1277       --  interfaces
1278
1279       Set_Parent              (Typ_Copy, Parent (Typ));
1280       Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
1281       Collect_All_Interfaces  (Typ_Copy);
1282
1283       --  Calculate the number of entries required in the table of interfaces
1284
1285       Num_Ifaces := 0;
1286       AI         := First_Elmt (Abstract_Interfaces (Typ_Copy));
1287
1288       while Present (AI) loop
1289          Num_Ifaces := Num_Ifaces + 1;
1290          Next_Elmt (AI);
1291       end loop;
1292
1293       --  Count ancestors to compute the inheritance depth. For private
1294       --  extensions, always go to the full view in order to compute the real
1295       --  inheritance depth.
1296
1297       declare
1298          Parent_Type : Entity_Id := Typ;
1299          P           : Entity_Id;
1300
1301       begin
1302          I_Depth := 0;
1303
1304          loop
1305             P := Etype (Parent_Type);
1306
1307             if Is_Private_Type (P) then
1308                P := Full_View (Base_Type (P));
1309             end if;
1310
1311             exit when P = Parent_Type;
1312
1313             I_Depth := I_Depth + 1;
1314             Parent_Type := P;
1315          end loop;
1316       end;
1317
1318       TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
1319       Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
1320
1321       --  ----------------------------------------------------------------
1322       --  Dispatch table and related entities are allocated statically
1323
1324       Set_Ekind (DT, E_Variable);
1325       Set_Is_Statically_Allocated (DT);
1326
1327       Set_Ekind (DT_Ptr, E_Variable);
1328       Set_Is_Statically_Allocated (DT_Ptr);
1329
1330       Set_Ekind (TSD, E_Variable);
1331       Set_Is_Statically_Allocated (TSD);
1332
1333       Set_Ekind (Exname, E_Variable);
1334       Set_Is_Statically_Allocated (Exname);
1335
1336       Set_Ekind (No_Reg, E_Variable);
1337       Set_Is_Statically_Allocated (No_Reg);
1338
1339       --  Generate code to create the storage for the Dispatch_Table object:
1340
1341       --   DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
1342       --   for DT'Alignment use Address'Alignment
1343
1344       Size_Expr_Node :=
1345         Make_Op_Add (Loc,
1346           Left_Opnd  => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
1347           Right_Opnd =>
1348             Make_Op_Multiply (Loc,
1349               Left_Opnd  =>
1350                 Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
1351               Right_Opnd =>
1352                 Make_Integer_Literal (Loc, Nb_Prim)));
1353
1354       Append_To (Result,
1355         Make_Object_Declaration (Loc,
1356           Defining_Identifier => DT,
1357           Aliased_Present     => True,
1358           Object_Definition   =>
1359             Make_Subtype_Indication (Loc,
1360               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
1361               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
1362                 Constraints => New_List (
1363                   Make_Range (Loc,
1364                     Low_Bound  => Make_Integer_Literal (Loc, 1),
1365                     High_Bound => Size_Expr_Node))))));
1366
1367       Append_To (Result,
1368         Make_Attribute_Definition_Clause (Loc,
1369           Name       => New_Reference_To (DT, Loc),
1370           Chars      => Name_Alignment,
1371           Expression =>
1372             Make_Attribute_Reference (Loc,
1373               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
1374               Attribute_Name => Name_Alignment)));
1375
1376       --  Generate code to create the pointer to the dispatch table
1377
1378       --    DT_Ptr : Tag := Tag!(DT'Address);
1379
1380       --  According to the C++ ABI, the base of the vtable is located after a
1381       --  prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
1382       --  down the pointer to the real base of the vtable
1383
1384       Append_To (Result,
1385         Make_Object_Declaration (Loc,
1386           Defining_Identifier => DT_Ptr,
1387           Constant_Present    => True,
1388           Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
1389           Expression          =>
1390             Unchecked_Convert_To (Generalized_Tag,
1391               Make_Op_Add (Loc,
1392                 Left_Opnd =>
1393                   Unchecked_Convert_To (RTE (RE_Storage_Offset),
1394                     Make_Attribute_Reference (Loc,
1395                       Prefix         => New_Reference_To (DT, Loc),
1396                       Attribute_Name => Name_Address)),
1397                 Right_Opnd =>
1398                   Make_DT_Access_Action (Typ,
1399                     DT_Prologue_Size, No_List)))));
1400
1401       --  Generate code to define the boolean that controls registration, in
1402       --  order to avoid multiple registrations for tagged types defined in
1403       --  multiple-called scopes
1404
1405       Append_To (Result,
1406         Make_Object_Declaration (Loc,
1407           Defining_Identifier => No_Reg,
1408           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
1409           Expression          => New_Reference_To (Standard_True, Loc)));
1410
1411       --  Set Access_Disp_Table field to be the dispatch table pointer
1412
1413       if not Present (Access_Disp_Table (Typ)) then
1414          Set_Access_Disp_Table (Typ, New_Elmt_List);
1415       end if;
1416
1417       Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
1418
1419       --  Generate code to create the storage for the type specific data object
1420       --  with enough space to store the tags of the ancestors plus the tags
1421       --  of all the implemented interfaces (as described in a-tags.adb)
1422       --
1423       --   TSD: Storage_Array
1424       --     (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
1425       --   for TSD'Alignment use Address'Alignment
1426
1427       Size_Expr_Node :=
1428         Make_Op_Add (Loc,
1429           Left_Opnd  =>
1430             Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
1431           Right_Opnd =>
1432             Make_Op_Multiply (Loc,
1433               Left_Opnd  =>
1434                 Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
1435               Right_Opnd =>
1436                 Make_Integer_Literal (Loc, TSD_Num_Entries)));
1437
1438       Append_To (Result,
1439         Make_Object_Declaration (Loc,
1440           Defining_Identifier => TSD,
1441           Aliased_Present     => True,
1442           Object_Definition   =>
1443             Make_Subtype_Indication (Loc,
1444               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
1445               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
1446                 Constraints => New_List (
1447                   Make_Range (Loc,
1448                     Low_Bound  => Make_Integer_Literal (Loc, 1),
1449                     High_Bound => Size_Expr_Node))))));
1450
1451       Append_To (Result,
1452         Make_Attribute_Definition_Clause (Loc,
1453           Name       => New_Reference_To (TSD, Loc),
1454           Chars      => Name_Alignment,
1455           Expression =>
1456             Make_Attribute_Reference (Loc,
1457               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
1458               Attribute_Name => Name_Alignment)));
1459
1460       --  Generate code to put the Address of the TSD in the dispatch table
1461       --    Set_TSD (DT_Ptr, TSD);
1462
1463       Append_To (Elab_Code,
1464         Make_DT_Access_Action (Typ,
1465           Action => Set_TSD,
1466           Args   => New_List (
1467             New_Reference_To (DT_Ptr, Loc),                  -- DTptr
1468               Make_Attribute_Reference (Loc,                 -- Value
1469               Prefix          => New_Reference_To (TSD, Loc),
1470               Attribute_Name  => Name_Address))));
1471
1472       --  Generate: Exname : constant String := full_qualified_name (typ);
1473       --  The type itself may be an anonymous parent type, so use the first
1474       --  subtype to have a user-recognizable name.
1475
1476       Append_To (Result,
1477         Make_Object_Declaration (Loc,
1478           Defining_Identifier => Exname,
1479           Constant_Present    => True,
1480           Object_Definition   => New_Reference_To (Standard_String, Loc),
1481           Expression =>
1482             Make_String_Literal (Loc,
1483               Full_Qualified_Name (First_Subtype (Typ)))));
1484
1485       --  Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
1486
1487       Append_To (Elab_Code,
1488         Make_DT_Access_Action (Typ,
1489           Action => Set_Expanded_Name,
1490           Args   => New_List (
1491             Node1 => New_Reference_To (DT_Ptr, Loc),
1492             Node2 =>
1493               Make_Attribute_Reference (Loc,
1494                 Prefix => New_Reference_To (Exname, Loc),
1495                 Attribute_Name => Name_Address))));
1496
1497       --  Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
1498
1499       Append_To (Elab_Code,
1500         Make_DT_Access_Action (Typ,
1501           Action => Set_Access_Level,
1502           Args   => New_List (
1503             Node1 => New_Reference_To (DT_Ptr, Loc),
1504             Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
1505
1506       --  Generate:
1507       --    Set_Offset_To_Top (DT_Ptr, 0);
1508
1509       Append_To (Elab_Code,
1510         Make_Procedure_Call_Statement (Loc,
1511           Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
1512           Parameter_Associations => New_List (
1513             New_Reference_To (DT_Ptr, Loc),
1514             Make_Integer_Literal (Loc, Uint_0))));
1515
1516       if Typ = Etype (Typ)
1517         or else Is_CPP_Class (Etype (Typ))
1518       then
1519          Old_Tag1 :=
1520            Unchecked_Convert_To (Generalized_Tag,
1521              Make_Integer_Literal (Loc, 0));
1522          Old_Tag2 :=
1523            Unchecked_Convert_To (Generalized_Tag,
1524              Make_Integer_Literal (Loc, 0));
1525
1526       else
1527          Old_Tag1 :=
1528            New_Reference_To
1529              (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
1530          Old_Tag2 :=
1531            New_Reference_To
1532              (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
1533       end if;
1534
1535       --  Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
1536
1537       Append_To (Elab_Code,
1538         Make_DT_Access_Action (Typ,
1539           Action => Inherit_DT,
1540           Args   => New_List (
1541             Node1 => Old_Tag1,
1542             Node2 => New_Reference_To (DT_Ptr, Loc),
1543             Node3 => Make_Integer_Literal (Loc,
1544                        DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
1545
1546       --  Inherit the secondary dispatch tables of the ancestor
1547
1548       if not Is_CPP_Class (Etype (Typ)) then
1549          declare
1550             Sec_DT_Ancestor : Elmt_Id :=
1551               Next_Elmt (First_Elmt (Access_Disp_Table (Etype (Typ))));
1552             Sec_DT_Typ      : Elmt_Id :=
1553               Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
1554
1555             procedure Copy_Secondary_DTs (Typ : Entity_Id);
1556             --  ??? comment required
1557
1558             ------------------------
1559             -- Copy_Secondary_DTs --
1560             ------------------------
1561
1562             procedure Copy_Secondary_DTs (Typ : Entity_Id) is
1563                E : Entity_Id;
1564
1565             begin
1566                if Etype (Typ) /= Typ then
1567                   Copy_Secondary_DTs (Etype (Typ));
1568                end if;
1569
1570                if Present (Abstract_Interfaces (Typ))
1571                  and then not Is_Empty_Elmt_List
1572                                 (Abstract_Interfaces (Typ))
1573                then
1574                   E := First_Entity (Typ);
1575
1576                   while Present (E)
1577                     and then Present (Node (Sec_DT_Ancestor))
1578                   loop
1579                      if Is_Tag (E) and then Chars (E) /= Name_uTag then
1580                         Append_To (Elab_Code,
1581                           Make_DT_Access_Action (Typ,
1582                             Action => Inherit_DT,
1583                             Args   => New_List (
1584                               Node1 => Unchecked_Convert_To
1585                                          (RTE (RE_Tag),
1586                                           New_Reference_To
1587                                             (Node (Sec_DT_Ancestor), Loc)),
1588                               Node2 => Unchecked_Convert_To
1589                                          (RTE (RE_Tag),
1590                                           New_Reference_To
1591                                             (Node (Sec_DT_Typ), Loc)),
1592                               Node3 => Make_Integer_Literal (Loc,
1593                                          DT_Entry_Count (E)))));
1594
1595                         Next_Elmt (Sec_DT_Ancestor);
1596                         Next_Elmt (Sec_DT_Typ);
1597                      end if;
1598
1599                      Next_Entity (E);
1600                   end loop;
1601                end if;
1602             end Copy_Secondary_DTs;
1603
1604          begin
1605             if Present (Node (Sec_DT_Ancestor)) then
1606                Copy_Secondary_DTs (Typ);
1607             end if;
1608          end;
1609       end if;
1610
1611       --  Generate: Inherit_TSD (parent'tag, DT_Ptr);
1612
1613       Append_To (Elab_Code,
1614         Make_DT_Access_Action (Typ,
1615           Action => Inherit_TSD,
1616           Args   => New_List (
1617             Node1 => Old_Tag2,
1618             Node2 => New_Reference_To (DT_Ptr, Loc))));
1619
1620       --  For types with no controlled components, generate:
1621       --    Set_RC_Offset (DT_Ptr, 0);
1622
1623       --  For simple types with controlled components, generate:
1624       --    Set_RC_Offset (DT_Ptr, type._record_controller'position);
1625
1626       --  For complex types with controlled components where the position
1627       --  of the record controller is not statically computable, if there are
1628       --  controlled components at this level, generate:
1629       --    Set_RC_Offset (DT_Ptr, -1);
1630       --  to indicate that the _controller field is right after the _parent
1631
1632       --  Or if there are no controlled components at this level, generate:
1633       --    Set_RC_Offset (DT_Ptr, -2);
1634       --  to indicate that we need to get the position from the parent.
1635
1636       declare
1637          Position : Node_Id;
1638
1639       begin
1640          if not Has_Controlled_Component (Typ) then
1641             Position := Make_Integer_Literal (Loc, 0);
1642
1643          elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then
1644             if Has_New_Controlled_Component (Typ) then
1645                Position := Make_Integer_Literal (Loc, -1);
1646             else
1647                Position := Make_Integer_Literal (Loc, -2);
1648             end if;
1649          else
1650             Position :=
1651               Make_Attribute_Reference (Loc,
1652                 Prefix =>
1653                   Make_Selected_Component (Loc,
1654                     Prefix => New_Reference_To (Typ, Loc),
1655                     Selector_Name =>
1656                       New_Reference_To (Controller_Component (Typ), Loc)),
1657                 Attribute_Name => Name_Position);
1658
1659             --  This is not proper Ada code to use the attribute 'Position
1660             --  on something else than an object but this is supported by
1661             --  the back end (see comment on the Bit_Component attribute in
1662             --  sem_attr). So we avoid semantic checking here.
1663
1664             --  Is this documented in sinfo.ads??? it should be!
1665
1666             Set_Analyzed (Position);
1667             Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
1668             Set_Etype (Prefix (Prefix (Position)), Typ);
1669             Set_Etype (Selector_Name (Prefix (Position)),
1670               RTE (RE_Record_Controller));
1671             Set_Etype (Position, RTE (RE_Storage_Offset));
1672          end if;
1673
1674          Append_To (Elab_Code,
1675            Make_DT_Access_Action (Typ,
1676              Action => Set_RC_Offset,
1677              Args   => New_List (
1678                Node1 => New_Reference_To (DT_Ptr, Loc),
1679                Node2 => Position)));
1680       end;
1681
1682       --  Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
1683       --  described in E.4 (18)
1684
1685       declare
1686          Status : Entity_Id;
1687
1688       begin
1689          Status :=
1690            Boolean_Literals
1691              (Is_Pure (Typ)
1692                 or else Is_Shared_Passive (Typ)
1693                 or else
1694                   ((Is_Remote_Types (Typ)
1695                       or else Is_Remote_Call_Interface (Typ))
1696                    and then Original_View_In_Visible_Part (Typ))
1697                 or else not Comes_From_Source (Typ));
1698
1699          Append_To (Elab_Code,
1700            Make_DT_Access_Action (Typ,
1701              Action => Set_Remotely_Callable,
1702              Args   => New_List (
1703                New_Occurrence_Of (DT_Ptr, Loc),
1704                New_Occurrence_Of (Status, Loc))));
1705       end;
1706
1707       --  Generate: Set_External_Tag (DT_Ptr, exname'Address);
1708       --  Should be the external name not the qualified name???
1709
1710       if not Has_External_Tag_Rep_Clause (Typ) then
1711          Append_To (Elab_Code,
1712            Make_DT_Access_Action (Typ,
1713              Action => Set_External_Tag,
1714              Args   => New_List (
1715                Node1 => New_Reference_To (DT_Ptr, Loc),
1716                Node2 =>
1717                  Make_Attribute_Reference (Loc,
1718                    Prefix => New_Reference_To (Exname, Loc),
1719                    Attribute_Name => Name_Address))));
1720
1721       --  Generate code to register the Tag in the External_Tag hash
1722       --  table for the pure Ada type only.
1723
1724       --        Register_Tag (Dt_Ptr);
1725
1726       --  Skip this if routine not available, or in No_Run_Time mode
1727
1728          if RTE_Available (RE_Register_Tag)
1729            and then Is_RTE (Generalized_Tag, RE_Tag)
1730            and then not No_Run_Time_Mode
1731          then
1732             Append_To (Elab_Code,
1733               Make_Procedure_Call_Statement (Loc,
1734                 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
1735                 Parameter_Associations =>
1736                   New_List (New_Reference_To (DT_Ptr, Loc))));
1737          end if;
1738       end if;
1739
1740       --  Generate:
1741       --     if No_Reg then
1742       --        <elab_code>
1743       --        No_Reg := False;
1744       --     end if;
1745
1746       Append_To (Elab_Code,
1747         Make_Assignment_Statement (Loc,
1748           Name       => New_Reference_To (No_Reg, Loc),
1749           Expression => New_Reference_To (Standard_False, Loc)));
1750
1751       Append_To (Result,
1752         Make_Implicit_If_Statement (Typ,
1753           Condition       => New_Reference_To (No_Reg, Loc),
1754           Then_Statements => Elab_Code));
1755
1756       --  Ada 2005 (AI-251): Register the tag of the interfaces into
1757       --  the table of implemented interfaces
1758
1759       if Present (Abstract_Interfaces (Typ_Copy))
1760         and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ_Copy))
1761       then
1762          AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
1763          while Present (AI) loop
1764
1765             --  Generate:
1766             --    Register_Interface (DT_Ptr, Interface'Tag);
1767
1768             Append_To (Result,
1769               Make_DT_Access_Action (Typ,
1770                 Action => Register_Interface_Tag,
1771                 Args   => New_List (
1772                   Node1 => New_Reference_To (DT_Ptr, Loc),
1773                   Node2 => New_Reference_To
1774                              (Node
1775                               (First_Elmt
1776                                (Access_Disp_Table (Node (AI)))),
1777                               Loc))));
1778
1779             Next_Elmt (AI);
1780          end loop;
1781       end if;
1782
1783       return Result;
1784    end Make_DT;
1785
1786    --------------------------------
1787    -- Make_Abstract_Interface_DT --
1788    --------------------------------
1789
1790    procedure Make_Abstract_Interface_DT
1791      (AI_Tag          : Entity_Id;
1792       Acc_Disp_Tables : in out Elist_Id;
1793       Result          : out List_Id)
1794    is
1795       Loc         : constant Source_Ptr := Sloc (AI_Tag);
1796       Name_DT     : constant Name_Id := New_Internal_Name ('T');
1797       Name_DT_Ptr : constant Name_Id := New_Internal_Name ('P');
1798
1799       Iface_DT     : constant Node_Id :=
1800                        Make_Defining_Identifier (Loc, Name_DT);
1801       Iface_DT_Ptr : constant Node_Id :=
1802                        Make_Defining_Identifier (Loc, Name_DT_Ptr);
1803
1804       Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
1805       Size_Expr_Node  : Node_Id;
1806       Nb_Prim         : Int;
1807
1808    begin
1809       Result := New_List;
1810
1811       --  Dispatch table and related entities are allocated statically
1812
1813       Set_Ekind (Iface_DT, E_Variable);
1814       Set_Is_Statically_Allocated (Iface_DT);
1815
1816       Set_Ekind (Iface_DT_Ptr, E_Variable);
1817       Set_Is_Statically_Allocated (Iface_DT_Ptr);
1818
1819       --  Generate code to create the storage for the Dispatch_Table object
1820
1821       --    DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
1822       --    for DT'Alignment use Address'Alignment
1823
1824       Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
1825
1826       Size_Expr_Node :=
1827         Make_Op_Add (Loc,
1828           Left_Opnd  => Make_DT_Access_Action (Etype (AI_Tag),
1829                           DT_Prologue_Size,
1830                           No_List),
1831           Right_Opnd =>
1832             Make_Op_Multiply (Loc,
1833               Left_Opnd  =>
1834                 Make_DT_Access_Action (Etype (AI_Tag),
1835                                        DT_Entry_Size,
1836                                        No_List),
1837               Right_Opnd =>
1838                 Make_Integer_Literal (Loc, Nb_Prim)));
1839
1840       Append_To (Result,
1841         Make_Object_Declaration (Loc,
1842           Defining_Identifier => Iface_DT,
1843           Aliased_Present     => True,
1844           Object_Definition   =>
1845             Make_Subtype_Indication (Loc,
1846               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
1847               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
1848                 Constraints => New_List (
1849                   Make_Range (Loc,
1850                     Low_Bound  => Make_Integer_Literal (Loc, 1),
1851                     High_Bound => Size_Expr_Node)))),
1852
1853             --  Initialize the signature of the interface tag. It is currently
1854             --  a sequence of four bytes located in the unused Typeinfo_Ptr
1855             --  field of the prologue). Its current value is the following
1856             --  sequence: (80, Nb_Prim, 0, 80)
1857
1858           Expression =>
1859             Make_Aggregate (Loc,
1860               Component_Associations => New_List (
1861                 Make_Component_Association (Loc,
1862
1863                   --  -80, 0, 0, -80
1864
1865                   Choices => New_List (
1866                     Make_Integer_Literal (Loc, Uint_5),
1867                     Make_Integer_Literal (Loc, Uint_8)),
1868                   Expression =>
1869                     Make_Integer_Literal (Loc, Uint_80)),
1870
1871                 Make_Component_Association (Loc,
1872                   Choices => New_List (
1873                     Make_Integer_Literal (Loc, Uint_2)),
1874                   Expression =>
1875                     Make_Integer_Literal (Loc, Nb_Prim)),
1876
1877                 Make_Component_Association (Loc,
1878                   Choices => New_List (
1879                     Make_Others_Choice (Loc)),
1880                   Expression => Make_Integer_Literal (Loc, Uint_0))))));
1881
1882       Append_To (Result,
1883         Make_Attribute_Definition_Clause (Loc,
1884           Name       => New_Reference_To (Iface_DT, Loc),
1885           Chars      => Name_Alignment,
1886           Expression =>
1887             Make_Attribute_Reference (Loc,
1888               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
1889               Attribute_Name => Name_Alignment)));
1890
1891       --  Generate code to create the pointer to the dispatch table
1892
1893       --    Iface_DT_Ptr : Tag := Tag!(DT'Address);
1894
1895       --  According to the C++ ABI, the base of the vtable is located
1896       --  after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
1897       --  Hence, move the pointer down to the real base of the vtable.
1898
1899       Append_To (Result,
1900         Make_Object_Declaration (Loc,
1901           Defining_Identifier => Iface_DT_Ptr,
1902           Constant_Present    => True,
1903           Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
1904           Expression          =>
1905             Unchecked_Convert_To (Generalized_Tag,
1906               Make_Op_Add (Loc,
1907                 Left_Opnd =>
1908                   Unchecked_Convert_To (RTE (RE_Storage_Offset),
1909                     Make_Attribute_Reference (Loc,
1910                       Prefix         => New_Reference_To (Iface_DT, Loc),
1911                       Attribute_Name => Name_Address)),
1912                 Right_Opnd =>
1913                   Make_DT_Access_Action (Etype (AI_Tag),
1914                     DT_Prologue_Size, No_List)))));
1915
1916       --  Note: Offset_To_Top will be initialized by the init subprogram
1917
1918       --  Set Access_Disp_Table field to be the dispatch table pointer
1919
1920       if not (Present (Acc_Disp_Tables)) then
1921          Acc_Disp_Tables := New_Elmt_List;
1922       end if;
1923
1924       Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
1925    end Make_Abstract_Interface_DT;
1926
1927    ---------------------------
1928    -- Make_DT_Access_Action --
1929    ---------------------------
1930
1931    function Make_DT_Access_Action
1932      (Typ    : Entity_Id;
1933       Action : DT_Access_Action;
1934       Args   : List_Id) return Node_Id
1935    is
1936       Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
1937       Loc         : Source_Ptr;
1938
1939    begin
1940       if No (Args) then
1941
1942          --  This is a constant
1943
1944          return New_Reference_To (Action_Name, Sloc (Typ));
1945       end if;
1946
1947       pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
1948
1949       Loc := Sloc (First (Args));
1950
1951       if Action_Is_Proc (Action) then
1952          return
1953            Make_Procedure_Call_Statement (Loc,
1954              Name => New_Reference_To (Action_Name, Loc),
1955              Parameter_Associations => Args);
1956
1957       else
1958          return
1959            Make_Function_Call (Loc,
1960              Name => New_Reference_To (Action_Name, Loc),
1961              Parameter_Associations => Args);
1962       end if;
1963    end Make_DT_Access_Action;
1964
1965    -----------------------------------
1966    -- Original_View_In_Visible_Part --
1967    -----------------------------------
1968
1969    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
1970       Scop : constant Entity_Id := Scope (Typ);
1971
1972    begin
1973       --  The scope must be a package
1974
1975       if Ekind (Scop) /= E_Package
1976         and then Ekind (Scop) /= E_Generic_Package
1977       then
1978          return False;
1979       end if;
1980
1981       --  A type with a private declaration has a private view declared in
1982       --  the visible part.
1983
1984       if Has_Private_Declaration (Typ) then
1985          return True;
1986       end if;
1987
1988       return List_Containing (Parent (Typ)) =
1989         Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
1990    end Original_View_In_Visible_Part;
1991
1992    -------------------------
1993    -- Set_All_DT_Position --
1994    -------------------------
1995
1996    procedure Set_All_DT_Position (Typ : Entity_Id) is
1997       Parent_Typ : constant Entity_Id := Etype (Typ);
1998       Root_Typ   : constant Entity_Id := Root_Type (Typ);
1999       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
2000       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
2001
2002       Adjusted   : Boolean := False;
2003       Finalized  : Boolean := False;
2004
2005       Count_Prim : Int;
2006       DT_Length  : Int;
2007       Nb_Prim    : Int;
2008       Parent_EC  : Int;
2009       Prim       : Entity_Id;
2010       Prim_Elmt  : Elmt_Id;
2011
2012       procedure Validate_Position (Prim : Entity_Id);
2013       --  Check that the position assignated to Prim is completely safe
2014       --  (it has not been assigned to a previously defined primitive
2015       --   operation of Typ)
2016
2017       -----------------------
2018       -- Validate_Position --
2019       -----------------------
2020
2021       procedure Validate_Position (Prim : Entity_Id) is
2022          Prim_Elmt : Elmt_Id;
2023       begin
2024          Prim_Elmt :=  First_Elmt (Primitive_Operations (Typ));
2025          while Present (Prim_Elmt)
2026             and then Node (Prim_Elmt) /= Prim
2027          loop
2028             --  Primitive operations covering abstract interfaces are
2029             --  allocated later
2030
2031             if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then
2032                null;
2033
2034             --  Predefined dispatching operations are completely safe.
2035             --  They are allocated at fixed positions.
2036
2037             elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
2038                null;
2039
2040             --  Aliased subprograms are safe
2041
2042             elsif Present (Alias (Prim)) then
2043                null;
2044
2045             elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then
2046                raise Program_Error;
2047             end if;
2048
2049             Next_Elmt (Prim_Elmt);
2050          end loop;
2051       end Validate_Position;
2052
2053    --  Start of processing for Set_All_DT_Position
2054
2055    begin
2056       --  Get Entry_Count of the parent
2057
2058       if Parent_Typ /= Typ
2059         and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
2060       then
2061          Parent_EC := UI_To_Int (DT_Entry_Count
2062                                    (First_Tag_Component (Parent_Typ)));
2063       else
2064          Parent_EC := 0;
2065       end if;
2066
2067       --  C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
2068       --  give a coherent set of information
2069
2070       if Is_CPP_Class (Root_Typ) then
2071
2072          --  Compute the number of primitive operations in the main Vtable
2073          --  Set their position:
2074          --    - where it was set if overriden or inherited
2075          --    - after the end of the parent vtable otherwise
2076
2077          Prim_Elmt := First_Prim;
2078          Nb_Prim := 0;
2079          while Present (Prim_Elmt) loop
2080             Prim := Node (Prim_Elmt);
2081
2082             if not Is_CPP_Class (Typ) then
2083                Set_DTC_Entity (Prim, The_Tag);
2084
2085             elsif Present (Alias (Prim)) then
2086                Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
2087                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
2088
2089             elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
2090                   Error_Msg_NE ("is a primitive operation of&," &
2091                     " pragma Cpp_Virtual required", Prim, Typ);
2092             end if;
2093
2094             if DTC_Entity (Prim) = The_Tag then
2095
2096                --  Get the slot from the parent subprogram if any
2097
2098                declare
2099                   H : Entity_Id := Homonym (Prim);
2100
2101                begin
2102                   while Present (H) loop
2103                      if Present (DTC_Entity (H))
2104                        and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
2105                      then
2106                         Set_DT_Position (Prim, DT_Position (H));
2107                         exit;
2108                      end if;
2109
2110                      H := Homonym (H);
2111                   end loop;
2112                end;
2113
2114                --  Otherwise take the canonical slot after the end of the
2115                --  parent Vtable
2116
2117                if DT_Position (Prim) = No_Uint then
2118                   Nb_Prim := Nb_Prim + 1;
2119                   Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
2120
2121                elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
2122                   Nb_Prim := Nb_Prim + 1;
2123                end if;
2124             end if;
2125
2126             Next_Elmt (Prim_Elmt);
2127          end loop;
2128
2129          --  Check that the declared size of the Vtable is bigger or equal
2130          --  than the number of primitive operations (if bigger it means that
2131          --  some of the c++ virtual functions were not imported, that is
2132          --  allowed)
2133
2134          if DT_Entry_Count (The_Tag) = No_Uint
2135            or else not Is_CPP_Class (Typ)
2136          then
2137             Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
2138
2139          elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
2140             Error_Msg_N ("not enough room in the Vtable for all virtual"
2141               & " functions", The_Tag);
2142          end if;
2143
2144          --  Check that Positions are not duplicate nor outside the range of
2145          --  the Vtable
2146
2147          declare
2148             Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
2149             Pos  : Int;
2150             Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
2151                                                         (others => Empty);
2152
2153          begin
2154             Prim_Elmt := First_Prim;
2155             while Present (Prim_Elmt) loop
2156                Prim := Node (Prim_Elmt);
2157
2158                if DTC_Entity (Prim) = The_Tag then
2159                   Pos := UI_To_Int (DT_Position (Prim));
2160
2161                   if Pos not in Prim_Pos_Table'Range then
2162                      Error_Msg_N
2163                        ("position not in range of virtual table", Prim);
2164
2165                   elsif Present (Prim_Pos_Table (Pos)) then
2166                      Error_Msg_NE ("cannot be at the same position in the"
2167                        & " vtable than&", Prim, Prim_Pos_Table (Pos));
2168
2169                   else
2170                      Prim_Pos_Table (Pos) := Prim;
2171                   end if;
2172                end if;
2173
2174                Next_Elmt (Prim_Elmt);
2175             end loop;
2176          end;
2177
2178       --  For regular Ada tagged types, just set the DT_Position for
2179       --  each primitive operation. Perform some sanity checks to avoid
2180       --  to build completely inconsistant dispatch tables.
2181
2182       --  Note that the _Size primitive is always set at position 1 in order
2183       --  to comply with the needs of Ada.Tags.Parent_Size (see documentation
2184       --  in a-tags.ad?)
2185
2186       else
2187          --  First stage: Set the DTC entity of all the primitive operations
2188          --  This is required to properly read the DT_Position attribute in
2189          --  the latter stages.
2190
2191          Prim_Elmt  := First_Prim;
2192          Count_Prim := 0;
2193
2194          while Present (Prim_Elmt) loop
2195             Count_Prim := Count_Prim + 1;
2196             Prim       := Node (Prim_Elmt);
2197
2198             --  Ada 2005 (AI-251)
2199
2200             if Present (Abstract_Interface_Alias (Prim)) then
2201                Set_DTC_Entity (Prim,
2202                   Find_Interface_Tag
2203                     (T => Typ,
2204                      Iface => Scope (DTC_Entity
2205                                       (Abstract_Interface_Alias (Prim)))));
2206
2207             else
2208                Set_DTC_Entity (Prim, The_Tag);
2209             end if;
2210
2211             --  Clear any previous value of the DT_Position attribute. In this
2212             --  way we ensure that the final position of all the primitives is
2213             --  stablished by the following stages of this algorithm.
2214
2215             Set_DT_Position (Prim, No_Uint);
2216
2217             Next_Elmt (Prim_Elmt);
2218          end loop;
2219
2220          declare
2221             Fixed_Prim : array (Int range 0 .. 10 + Parent_EC + Count_Prim)
2222                             of Boolean := (others => False);
2223             E          : Entity_Id;
2224
2225          begin
2226             --  Second stage: Register fixed entries
2227
2228             Nb_Prim   := 10;
2229             Prim_Elmt := First_Prim;
2230
2231             while Present (Prim_Elmt) loop
2232                Prim := Node (Prim_Elmt);
2233
2234                --  Predefined primitives have a fixed position in all the
2235                --  dispatch tables
2236
2237                if Is_Predefined_Dispatching_Operation (Prim) then
2238                   Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
2239                   Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
2240
2241                --  Overriding interface primitives of an ancestor
2242
2243                elsif DT_Position (Prim) = No_Uint
2244                  and then Present (Abstract_Interface_Alias (Prim))
2245                  and then Present (DTC_Entity
2246                                    (Abstract_Interface_Alias (Prim)))
2247                  and then DT_Position (Abstract_Interface_Alias (Prim))
2248                                         /= No_Uint
2249                  and then Is_Inherited_Operation (Prim)
2250                  and then Is_Ancestor (Scope
2251                                        (DTC_Entity
2252                                         (Abstract_Interface_Alias (Prim))),
2253                                        Typ)
2254                then
2255                   Set_DT_Position (Prim,
2256                     DT_Position (Abstract_Interface_Alias (Prim)));
2257                   Set_DT_Position (Alias (Prim),
2258                     DT_Position (Abstract_Interface_Alias (Prim)));
2259                   Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
2260
2261                --  Overriding primitives must use the same entry as the
2262                --  overriden primitive
2263
2264                elsif DT_Position (Prim) = No_Uint
2265                  and then Present (Alias (Prim))
2266                  and then Present (DTC_Entity (Alias (Prim)))
2267                  and then DT_Position (Alias (Prim)) /= No_Uint
2268                  and then Is_Inherited_Operation (Prim)
2269                  and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ)
2270                then
2271                   E := Alias (Prim);
2272                   while not (Present (DTC_Entity (E))
2273                               or else DT_Position (E) = No_Uint)
2274                     and then Present (Alias (E))
2275                   loop
2276                      E := Alias (E);
2277                   end loop;
2278
2279                   pragma Assert (Present (DTC_Entity (E))
2280                                    and then
2281                                  DT_Position (E) /= No_Uint);
2282
2283                   Set_DT_Position (Prim, DT_Position (E));
2284                   Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
2285
2286                   --  If this is not the last element in the chain continue
2287                   --  traversing the chain. This is required to properly
2288                   --  handling renamed primitives
2289
2290                   if Present (Alias (E)) then
2291                      while Present (Alias (E)) loop
2292                         E   := Alias (E);
2293                         Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
2294                      end loop;
2295                   end if;
2296                end if;
2297
2298                Next_Elmt (Prim_Elmt);
2299             end loop;
2300
2301             --  Third stage: Fix the position of all the new primitives
2302             --  Entries associated with primitives covering interfaces
2303             --  are handled in a latter round.
2304
2305             Prim_Elmt := First_Prim;
2306             while Present (Prim_Elmt) loop
2307                Prim := Node (Prim_Elmt);
2308
2309                --  Skip primitives previously set entries
2310
2311                if DT_Position (Prim) /= No_Uint then
2312                   null;
2313
2314                elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then
2315                   null;
2316
2317                --  Primitives covering interface primitives are
2318                --  handled later
2319
2320                elsif Present (Abstract_Interface_Alias (Prim)) then
2321                   null;
2322
2323                else
2324                   --  Take the next available position in the DT
2325
2326                   loop
2327                      Nb_Prim := Nb_Prim + 1;
2328                      exit when not Fixed_Prim (Nb_Prim);
2329                   end loop;
2330
2331                   Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
2332                   Fixed_Prim (Nb_Prim) := True;
2333                end if;
2334
2335                Next_Elmt (Prim_Elmt);
2336             end loop;
2337          end;
2338
2339          --  Fourth stage: Complete the decoration of primitives covering
2340          --  interfaces (that is, propagate the DT_Position attribute
2341          --  from the aliased primitive)
2342
2343          Prim_Elmt := First_Prim;
2344          while Present (Prim_Elmt) loop
2345             Prim := Node (Prim_Elmt);
2346
2347             if DT_Position (Prim) = No_Uint
2348                and then Present (Abstract_Interface_Alias (Prim))
2349             then
2350                --  Check if this entry will be placed in the primary DT
2351
2352                if Etype (DTC_Entity (Abstract_Interface_Alias (Prim)))
2353                     = RTE (RE_Tag)
2354                then
2355                   pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
2356                   Set_DT_Position (Prim, DT_Position (Alias (Prim)));
2357
2358                --  Otherwise it will be placed in the secondary DT
2359
2360                else
2361                   pragma Assert
2362                     (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
2363
2364                   Set_DT_Position (Prim,
2365                      DT_Position (Abstract_Interface_Alias (Prim)));
2366                end if;
2367             end if;
2368
2369             Next_Elmt (Prim_Elmt);
2370          end loop;
2371
2372          --  Final stage: Ensure that the table is correct plus some further
2373          --  verifications concerning the primitives.
2374
2375          Prim_Elmt := First_Prim;
2376          DT_Length := 0;
2377
2378          while Present (Prim_Elmt) loop
2379             Prim := Node (Prim_Elmt);
2380
2381             --  At this point all the primitives MUST have a position
2382             --  in the dispatch table
2383
2384             if DT_Position (Prim) = No_Uint then
2385                raise Program_Error;
2386             end if;
2387
2388             --  Calculate real size of the dispatch table
2389
2390             if UI_To_Int (DT_Position (Prim)) > DT_Length then
2391                DT_Length := UI_To_Int (DT_Position (Prim));
2392             end if;
2393
2394             --  Ensure that the asignated position in the dispatch
2395             --  table is correct
2396
2397             Validate_Position (Prim);
2398
2399             if Chars (Prim) = Name_Finalize then
2400                Finalized := True;
2401             end if;
2402
2403             if Chars (Prim) = Name_Adjust then
2404                Adjusted := True;
2405             end if;
2406
2407             --  An abstract operation cannot be declared in the private part
2408             --  for a visible abstract type, because it could never be over-
2409             --  ridden. For explicit declarations this is checked at the
2410             --  point of declaration, but for inherited operations it must
2411             --  be done when building the dispatch table. Input is excluded
2412             --  because
2413
2414             if Is_Abstract (Typ)
2415               and then Is_Abstract (Prim)
2416               and then Present (Alias (Prim))
2417               and then Is_Derived_Type (Typ)
2418               and then In_Private_Part (Current_Scope)
2419               and then
2420                 List_Containing (Parent (Prim)) =
2421                   Private_Declarations
2422                    (Specification (Unit_Declaration_Node (Current_Scope)))
2423               and then Original_View_In_Visible_Part (Typ)
2424             then
2425                --  We exclude Input and Output stream operations because
2426                --  Limited_Controlled inherits useless Input and Output
2427                --  stream operations from Root_Controlled, which can
2428                --  never be overridden.
2429
2430                if not Is_TSS (Prim, TSS_Stream_Input)
2431                     and then
2432                   not Is_TSS (Prim, TSS_Stream_Output)
2433                then
2434                   Error_Msg_NE
2435                     ("abstract inherited private operation&" &
2436                      " must be overridden ('R'M 3.9.3(10))",
2437                     Parent (Typ), Prim);
2438                end if;
2439             end if;
2440
2441             Next_Elmt (Prim_Elmt);
2442          end loop;
2443
2444          --  Additional check
2445
2446          if Is_Controlled (Typ) then
2447             if not Finalized then
2448                Error_Msg_N
2449                  ("controlled type has no explicit Finalize method?", Typ);
2450
2451             elsif not Adjusted then
2452                Error_Msg_N
2453                  ("controlled type has no explicit Adjust method?", Typ);
2454             end if;
2455          end if;
2456
2457          --  Set the final size of the Dispatch Table
2458
2459          Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
2460
2461          --  The derived type must have at least as many components as its
2462          --  parent (for root types, the Etype points back to itself
2463          --  and the test should not fail)
2464
2465          --  This test fails compiling the partial view of a tagged type
2466          --  derived from an interface which defines the overriding subprogram
2467          --  in the private part. This needs further investigation???
2468
2469          if not Has_Private_Declaration (Typ) then
2470             pragma Assert (
2471               DT_Entry_Count (The_Tag) >=
2472               DT_Entry_Count (First_Tag_Component (Parent_Typ)));
2473             null;
2474          end if;
2475       end if;
2476
2477       if Debug_Flag_ZZ then
2478          Write_DT (Typ);
2479       end if;
2480    end Set_All_DT_Position;
2481
2482    -----------------------------
2483    -- Set_Default_Constructor --
2484    -----------------------------
2485
2486    procedure Set_Default_Constructor (Typ : Entity_Id) is
2487       Loc   : Source_Ptr;
2488       Init  : Entity_Id;
2489       Param : Entity_Id;
2490       E     : Entity_Id;
2491
2492    begin
2493       --  Look for the default constructor entity. For now only the
2494       --  default constructor has the flag Is_Constructor.
2495
2496       E := Next_Entity (Typ);
2497       while Present (E)
2498         and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
2499       loop
2500          Next_Entity (E);
2501       end loop;
2502
2503       --  Create the init procedure
2504
2505       if Present (E) then
2506          Loc   := Sloc (E);
2507          Init  := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
2508          Param := Make_Defining_Identifier (Loc, Name_X);
2509
2510          Discard_Node (
2511            Make_Subprogram_Declaration (Loc,
2512              Make_Procedure_Specification (Loc,
2513                Defining_Unit_Name => Init,
2514                Parameter_Specifications => New_List (
2515                  Make_Parameter_Specification (Loc,
2516                    Defining_Identifier => Param,
2517                    Parameter_Type      => New_Reference_To (Typ, Loc))))));
2518
2519          Set_Init_Proc (Typ, Init);
2520          Set_Is_Imported    (Init);
2521          Set_Interface_Name (Init, Interface_Name (E));
2522          Set_Convention     (Init, Convention_C);
2523          Set_Is_Public      (Init);
2524          Set_Has_Completion (Init);
2525
2526       --  If there are no constructors, mark the type as abstract since we
2527       --  won't be able to declare objects of that type.
2528
2529       else
2530          Set_Is_Abstract (Typ);
2531       end if;
2532    end Set_Default_Constructor;
2533
2534    --------------
2535    -- Write_DT --
2536    --------------
2537
2538    procedure Write_DT (Typ : Entity_Id) is
2539       Elmt : Elmt_Id;
2540       Prim : Node_Id;
2541
2542    begin
2543       --  Protect this procedure against wrong usage. Required because it will
2544       --  be used directly from GDB
2545
2546       if not (Typ in First_Node_Id .. Last_Node_Id)
2547         or else not Is_Tagged_Type (Typ)
2548       then
2549          Write_Str ("wrong usage: write_dt must be used with tagged types");
2550          Write_Eol;
2551          return;
2552       end if;
2553
2554       Write_Int (Int (Typ));
2555       Write_Str (": ");
2556       Write_Name (Chars (Typ));
2557
2558       if Is_Interface (Typ) then
2559          Write_Str (" is interface");
2560       end if;
2561
2562       Write_Eol;
2563
2564       Elmt := First_Elmt (Primitive_Operations (Typ));
2565       while Present (Elmt) loop
2566          Prim := Node (Elmt);
2567          Write_Str  (" - ");
2568
2569          --  Indicate if this primitive will be allocated in the primary
2570          --  dispatch table or in a secondary dispatch table associated
2571          --  with an abstract interface type
2572
2573          if Present (DTC_Entity (Prim)) then
2574             if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
2575                Write_Str ("[P] ");
2576             else
2577                Write_Str ("[s] ");
2578             end if;
2579          end if;
2580
2581          --  Output the node of this primitive operation and its name
2582
2583          Write_Int  (Int (Prim));
2584          Write_Str  (": ");
2585          Write_Name (Chars (Prim));
2586
2587          --  Indicate if this primitive has an aliased primitive
2588
2589          if Present (Alias (Prim)) then
2590             Write_Str (" (alias = ");
2591             Write_Int (Int (Alias (Prim)));
2592
2593             --  If the DTC_Entity attribute is already set we can also output
2594             --  the name of the interface covered by this primitive (if any)
2595
2596             if Present (DTC_Entity (Alias (Prim)))
2597               and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
2598             then
2599                Write_Str  (" from interface ");
2600                Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
2601             end if;
2602
2603             if Present (Abstract_Interface_Alias (Prim)) then
2604                Write_Str  (", AI_Alias of ");
2605                Write_Name (Chars (Scope (DTC_Entity
2606                                           (Abstract_Interface_Alias (Prim)))));
2607                Write_Char (':');
2608                Write_Int  (Int (Abstract_Interface_Alias (Prim)));
2609             end if;
2610
2611             Write_Str (")");
2612          end if;
2613
2614          --  Display the final position of this primitive in its associated
2615          --  (primary or secondary) dispatch table
2616
2617          if Present (DTC_Entity (Prim))
2618            and then DT_Position (Prim) /= No_Uint
2619          then
2620             Write_Str (" at #");
2621             Write_Int (UI_To_Int (DT_Position (Prim)));
2622          end if;
2623
2624          if Is_Abstract (Prim) then
2625             Write_Str (" is abstract;");
2626          end if;
2627
2628          Write_Eol;
2629
2630          Next_Elmt (Elmt);
2631       end loop;
2632    end Write_DT;
2633
2634 end Exp_Disp;