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_Id    : Entity_Id;
 906       Iface_Tag   : Entity_Id) return Node_Id
 907    is
 908       Loc         : constant Source_Ptr := Sloc (N);
 909       Actuals     : constant List_Id    := New_List;
 910       Decl        : constant List_Id    := New_List;
 911       Formals     : constant List_Id    := New_List;
 912       Thunk_Tag   : constant Node_Id    := Iface_Tag;
 913       Thunk_Alias : constant Entity_Id  := Alias (Entity (N));
 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 (Entity (N))), Loc));
 954
 955             --  Why is this line silently commented out ???
 956
 957             --  New_Reference_To (Etype (Formal), Loc));
 958          end if;
 959
 960          Append_To (Formals, New_Formal);
 961          Next_Formal (Formal);
 962       end loop;
 963
 964       if Ekind (First_Formal (Thunk_Alias)) = E_In_Parameter
 965         and then Ekind (Etype (First_Formal (Thunk_Alias)))
 966                   = E_Anonymous_Access_Type
 967       then
 968
 969          --  Generate:
 970
 971          --     type T is access all <<type of the first formal>>
 972          --     S1 := Storage_Offset!(First_formal)
 973          --           - Storage_Offset!(First_Formal.Thunk_Tag'Position)
 974
 975          --  ... and the first actual of the call is generated as T!(S1)
 976
 977          Decl_2 :=
 978            Make_Full_Type_Declaration (Loc,
 979              Defining_Identifier =>
 980                Make_Defining_Identifier (Loc,
 981                  New_Internal_Name ('T')),
 982              Type_Definition =>
 983                Make_Access_To_Object_Definition (Loc,
 984                  All_Present            => True,
 985                  Null_Exclusion_Present => False,
 986                  Constant_Present       => False,
 987                  Subtype_Indication     =>
 988                    New_Reference_To
 989                      (Directly_Designated_Type
 990                         (Etype (First_Formal (Thunk_Alias))), Loc)
 991                          ));
 992
 993          Decl_1 :=
 994            Make_Object_Declaration (Loc,
 995              Defining_Identifier =>
 996                Make_Defining_Identifier (Loc,
 997                  New_Internal_Name ('S')),
 998              Constant_Present    => True,
 999              Object_Definition   =>
1000                New_Reference_To (RTE (RE_Storage_Offset), Loc),
1001              Expression          =>
1002                Make_Op_Subtract (Loc,
1003                  Left_Opnd  =>
1004                    Unchecked_Convert_To
1005                      (RTE (RE_Storage_Offset),
1006                       New_Reference_To
1007                         (Defining_Identifier (First (Formals)), Loc)),
1008                   Right_Opnd =>
1009                     Unchecked_Convert_To
1010                       (RTE (RE_Storage_Offset),
1011                        Make_Attribute_Reference (Loc,
1012                          Prefix =>
1013                            Make_Selected_Component (Loc,
1014                              Prefix =>
1015                                New_Reference_To
1016                                  (Defining_Identifier (First (Formals)), Loc),
1017                              Selector_Name =>
1018                                New_Occurrence_Of (Thunk_Tag, Loc)),
1019                          Attribute_Name => Name_Position))));
1020
1021          Append_To (Decl, Decl_2);
1022          Append_To (Decl, Decl_1);
1023
1024          --  Reference the new first actual
1025
1026          Append_To (Actuals,
1027            Unchecked_Convert_To
1028              (Defining_Identifier (Decl_2),
1029               New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1030
1031          --  Side note: The reverse order of declarations is just to ensure
1032          --  that the call to RE_Print is correct.
1033
1034       else
1035          --  Generate:
1036          --
1037          --     S1 := Storage_Offset!(First_formal'Address)
1038          --           - Storage_Offset!(First_Formal.Thunk_Tag'Position)
1039          --     S2 := Tag_Ptr!(S3)
1040
1041          Decl_1 :=
1042            Make_Object_Declaration (Loc,
1043              Defining_Identifier =>
1044                Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1045              Constant_Present    => True,
1046              Object_Definition   =>
1047                New_Reference_To (RTE (RE_Storage_Offset), Loc),
1048              Expression          =>
1049                Make_Op_Subtract (Loc,
1050                  Left_Opnd =>
1051                    Unchecked_Convert_To
1052                      (RTE (RE_Storage_Offset),
1053                       Make_Attribute_Reference (Loc,
1054                         Prefix =>
1055                           New_Reference_To
1056                             (Defining_Identifier (First (Formals)), Loc),
1057                         Attribute_Name => Name_Address)),
1058                  Right_Opnd =>
1059                    Unchecked_Convert_To
1060                      (RTE (RE_Storage_Offset),
1061                       Make_Attribute_Reference (Loc,
1062                         Prefix =>
1063                           Make_Selected_Component (Loc,
1064                             Prefix =>
1065                               New_Reference_To
1066                                 (Defining_Identifier (First (Formals)), Loc),
1067                                  Selector_Name =>
1068                                    New_Occurrence_Of (Thunk_Tag, Loc)),
1069                         Attribute_Name => Name_Position))));
1070
1071          Decl_2 :=
1072            Make_Object_Declaration (Loc,
1073              Defining_Identifier =>
1074                Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1075              Constant_Present    => True,
1076              Object_Definition   => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1077              Expression          =>
1078                Unchecked_Convert_To
1079                  (RTE (RE_Addr_Ptr),
1080                   New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1081
1082          Append_To (Decl, Decl_1);
1083          Append_To (Decl, Decl_2);
1084
1085          --  Reference the new first actual
1086
1087          Append_To (Actuals,
1088            Unchecked_Convert_To
1089              (Etype (First_Entity (Target)),
1090               Make_Explicit_Dereference (Loc,
1091                 New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1092
1093       end if;
1094
1095       Formal := Next (First (Formals));
1096       while Present (Formal) loop
1097          Append_To (Actuals,
1098             New_Reference_To (Defining_Identifier (Formal), Loc));
1099          Next (Formal);
1100       end loop;
1101
1102       if Ekind (Thunk_Alias) = E_Procedure then
1103          New_Code :=
1104            Make_Subprogram_Body (Loc,
1105               Specification =>
1106                 Make_Procedure_Specification (Loc,
1107                   Defining_Unit_Name       => Thunk_Id,
1108                   Parameter_Specifications => Formals),
1109               Declarations => Decl,
1110               Handled_Statement_Sequence =>
1111                 Make_Handled_Sequence_Of_Statements (Loc,
1112                   Statements => New_List (
1113                     Make_Procedure_Call_Statement (Loc,
1114                        Name => New_Occurrence_Of (Target, Loc),
1115                        Parameter_Associations => Actuals))));
1116
1117       else pragma Assert (Ekind (Thunk_Alias) = E_Function);
1118
1119          if not Present (Alias (Thunk_Alias)) then
1120             Subtyp_Mark := Subtype_Mark (Parent (Thunk_Alias));
1121          else
1122             --  The last element in the alias list has the correct subtype_mark
1123             --  of the function result
1124
1125             declare
1126                E : Entity_Id := Alias (Thunk_Alias);
1127             begin
1128                while Present (Alias (E)) loop
1129                   E := Alias (E);
1130                end loop;
1131                Subtyp_Mark := Subtype_Mark (Parent (E));
1132             end;
1133          end if;
1134
1135          New_Code :=
1136            Make_Subprogram_Body (Loc,
1137               Specification =>
1138                 Make_Function_Specification (Loc,
1139                   Defining_Unit_Name       => Thunk_Id,
1140                   Parameter_Specifications => Formals,
1141                   Subtype_Mark => New_Copy (Subtyp_Mark)),
1142               Declarations => Decl,
1143               Handled_Statement_Sequence =>
1144                 Make_Handled_Sequence_Of_Statements (Loc,
1145                   Statements => New_List (
1146                     Make_Return_Statement (Loc,
1147                       Make_Function_Call (Loc,
1148                         Name => New_Occurrence_Of (Target, Loc),
1149                         Parameter_Associations => Actuals)))));
1150       end if;
1151
1152       Analyze (New_Code);
1153       Insert_After (N, New_Code);
1154       return New_Code;
1155    end Expand_Interface_Thunk;
1156
1157    -------------
1158    -- Fill_DT --
1159    -------------
1160
1161    function Fill_DT_Entry
1162      (Loc      : Source_Ptr;
1163       Prim     : Entity_Id;
1164       Thunk_Id : Entity_Id := Empty) return Node_Id
1165    is
1166       Typ     : constant Entity_Id := Scope (DTC_Entity (Prim));
1167       DT_Ptr  : Entity_Id := Node (First_Elmt (Access_Disp_Table (Typ)));
1168       Target  : Entity_Id;
1169       Tag     : Entity_Id := First_Tag_Component (Typ);
1170       Prim_Op : Entity_Id := Prim;
1171
1172    begin
1173       --  Ada 2005 (AI-251): If we have a thunk available then generate code
1174       --  that saves its address in the secondary dispatch table of its
1175       --  abstract interface; otherwise save the address of the primitive
1176       --  subprogram in the main virtual table.
1177
1178       if Thunk_Id /= Empty then
1179          Target := Thunk_Id;
1180       else
1181          Target := Prim;
1182       end if;
1183
1184       --  Ada 2005 (AI-251): If the subprogram is the alias of an abstract
1185       --  interface subprogram then find the correct dispatch table pointer
1186
1187       if Present (Abstract_Interface_Alias (Prim)) then
1188          Prim_Op := Abstract_Interface_Alias (Prim);
1189
1190          DT_Ptr  := Find_Interface_ADT
1191                       (T     => Typ,
1192                        Iface => Scope (DTC_Entity (Prim_Op)));
1193
1194          Tag := First_Tag_Component (Scope (DTC_Entity (Prim_Op)));
1195       end if;
1196
1197       pragma Assert (DT_Position (Prim_Op) <= DT_Entry_Count (Tag));
1198       pragma Assert (DT_Position (Prim_Op) > Uint_0);
1199
1200       return
1201         Make_DT_Access_Action (Typ,
1202           Action => Set_Prim_Op_Address,
1203           Args   => New_List (
1204             Unchecked_Convert_To (RTE (RE_Tag),
1205               New_Reference_To (DT_Ptr, Loc)),                  -- DTptr
1206
1207             Make_Integer_Literal (Loc, DT_Position (Prim_Op)),  -- Position
1208
1209             Make_Attribute_Reference (Loc,                      -- Value
1210               Prefix          => New_Reference_To (Target, Loc),
1211               Attribute_Name  => Name_Address)));
1212    end Fill_DT_Entry;
1213
1214    ---------------------------
1215    -- Get_Remotely_Callable --
1216    ---------------------------
1217
1218    function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
1219       Loc : constant Source_Ptr := Sloc (Obj);
1220
1221    begin
1222       return Make_DT_Access_Action
1223         (Typ    => Etype (Obj),
1224          Action => Get_Remotely_Callable,
1225          Args   => New_List (
1226            Make_Selected_Component (Loc,
1227              Prefix        => Obj,
1228              Selector_Name => Make_Identifier (Loc, Name_uTag))));
1229    end Get_Remotely_Callable;
1230
1231    -------------
1232    -- Make_DT --
1233    -------------
1234
1235    function Make_DT (Typ : Entity_Id) return List_Id is
1236       Loc         : constant Source_Ptr := Sloc (Typ);
1237       Result      : constant List_Id    := New_List;
1238       Elab_Code   : constant List_Id    := New_List;
1239
1240       Tname       : constant Name_Id := Chars (Typ);
1241       Name_DT     : constant Name_Id := New_External_Name (Tname, 'T');
1242       Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
1243       Name_TSD    : constant Name_Id := New_External_Name (Tname, 'B');
1244       Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
1245       Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
1246
1247       DT     : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
1248       DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
1249       TSD    : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
1250       Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
1251       No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
1252
1253       Generalized_Tag : constant Entity_Id := RTE (RE_Tag);
1254       I_Depth         : Int;
1255       Size_Expr_Node  : Node_Id;
1256       Old_Tag1        : Node_Id;
1257       Old_Tag2        : Node_Id;
1258       Num_Ifaces      : Int;
1259       Nb_Prim         : Int;
1260       TSD_Num_Entries : Int;
1261       Typ_Copy        : constant Entity_Id := New_Copy (Typ);
1262       AI              : Elmt_Id;
1263
1264    begin
1265       if not RTE_Available (RE_Tag) then
1266          Error_Msg_CRT ("tagged types", Typ);
1267          return New_List;
1268       end if;
1269
1270       --  Collect the full list of directly and indirectly implemented
1271       --  interfaces
1272
1273       Set_Parent              (Typ_Copy, Parent (Typ));
1274       Set_Abstract_Interfaces (Typ_Copy, New_Elmt_List);
1275       Collect_All_Interfaces  (Typ_Copy);
1276
1277       --  Calculate the number of entries required in the table of interfaces
1278
1279       Num_Ifaces := 0;
1280       AI         := First_Elmt (Abstract_Interfaces (Typ_Copy));
1281
1282       while Present (AI) loop
1283          Num_Ifaces := Num_Ifaces + 1;
1284          Next_Elmt (AI);
1285       end loop;
1286
1287       --  Count ancestors to compute the inheritance depth. For private
1288       --  extensions, always go to the full view in order to compute the real
1289       --  inheritance depth.
1290
1291       declare
1292          Parent_Type : Entity_Id := Typ;
1293          P           : Entity_Id;
1294
1295       begin
1296          I_Depth := 0;
1297
1298          loop
1299             P := Etype (Parent_Type);
1300
1301             if Is_Private_Type (P) then
1302                P := Full_View (Base_Type (P));
1303             end if;
1304
1305             exit when P = Parent_Type;
1306
1307             I_Depth := I_Depth + 1;
1308             Parent_Type := P;
1309          end loop;
1310       end;
1311
1312       TSD_Num_Entries := I_Depth + Num_Ifaces + 1;
1313       Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
1314
1315       --  ----------------------------------------------------------------
1316
1317       --  Dispatch table and related entities are allocated statically
1318
1319       Set_Ekind (DT, E_Variable);
1320       Set_Is_Statically_Allocated (DT);
1321
1322       Set_Ekind (DT_Ptr, E_Variable);
1323       Set_Is_Statically_Allocated (DT_Ptr);
1324
1325       Set_Ekind (TSD, E_Variable);
1326       Set_Is_Statically_Allocated (TSD);
1327
1328       Set_Ekind (Exname, E_Variable);
1329       Set_Is_Statically_Allocated (Exname);
1330
1331       Set_Ekind (No_Reg, E_Variable);
1332       Set_Is_Statically_Allocated (No_Reg);
1333
1334       --  Generate code to create the storage for the Dispatch_Table object:
1335
1336       --   DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
1337       --   for DT'Alignment use Address'Alignment
1338
1339       Size_Expr_Node :=
1340         Make_Op_Add (Loc,
1341           Left_Opnd  => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
1342           Right_Opnd =>
1343             Make_Op_Multiply (Loc,
1344               Left_Opnd  =>
1345                 Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
1346               Right_Opnd =>
1347                 Make_Integer_Literal (Loc, Nb_Prim)));
1348
1349       Append_To (Result,
1350         Make_Object_Declaration (Loc,
1351           Defining_Identifier => DT,
1352           Aliased_Present     => True,
1353           Object_Definition   =>
1354             Make_Subtype_Indication (Loc,
1355               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
1356               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
1357                 Constraints => New_List (
1358                   Make_Range (Loc,
1359                     Low_Bound  => Make_Integer_Literal (Loc, 1),
1360                     High_Bound => Size_Expr_Node))))));
1361
1362       Append_To (Result,
1363         Make_Attribute_Definition_Clause (Loc,
1364           Name       => New_Reference_To (DT, Loc),
1365           Chars      => Name_Alignment,
1366           Expression =>
1367             Make_Attribute_Reference (Loc,
1368               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
1369               Attribute_Name => Name_Alignment)));
1370
1371       --  Generate code to create the pointer to the dispatch table
1372
1373       --    DT_Ptr : Tag := Tag!(DT'Address);
1374
1375       --  According to the C++ ABI, the base of the vtable is located after a
1376       --  prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
1377       --  down the pointer to the real base of the vtable
1378
1379       Append_To (Result,
1380         Make_Object_Declaration (Loc,
1381           Defining_Identifier => DT_Ptr,
1382           Constant_Present    => True,
1383           Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
1384           Expression          =>
1385             Unchecked_Convert_To (Generalized_Tag,
1386               Make_Op_Add (Loc,
1387                 Left_Opnd =>
1388                   Unchecked_Convert_To (RTE (RE_Storage_Offset),
1389                     Make_Attribute_Reference (Loc,
1390                       Prefix         => New_Reference_To (DT, Loc),
1391                       Attribute_Name => Name_Address)),
1392                 Right_Opnd =>
1393                   Make_DT_Access_Action (Typ,
1394                     DT_Prologue_Size, No_List)))));
1395
1396       --  Generate code to define the boolean that controls registration, in
1397       --  order to avoid multiple registrations for tagged types defined in
1398       --  multiple-called scopes
1399
1400       Append_To (Result,
1401         Make_Object_Declaration (Loc,
1402           Defining_Identifier => No_Reg,
1403           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
1404           Expression          => New_Reference_To (Standard_True, Loc)));
1405
1406       --  Set Access_Disp_Table field to be the dispatch table pointer
1407
1408       if not Present (Access_Disp_Table (Typ)) then
1409          Set_Access_Disp_Table (Typ, New_Elmt_List);
1410       end if;
1411
1412       Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
1413
1414       --  Generate code to create the storage for the type specific data object
1415       --  with enough space to store the tags of the ancestors plus the tags
1416       --  of all the implemented interfaces (as described in a-tags.adb)
1417       --
1418       --   TSD: Storage_Array
1419       --     (1..TSD_Prologue_Size+TSD_Num_Entries*TSD_Entry_Size);
1420       --   for TSD'Alignment use Address'Alignment
1421
1422       Size_Expr_Node :=
1423         Make_Op_Add (Loc,
1424           Left_Opnd  =>
1425             Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
1426           Right_Opnd =>
1427             Make_Op_Multiply (Loc,
1428               Left_Opnd  =>
1429                 Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
1430               Right_Opnd =>
1431                 Make_Integer_Literal (Loc, TSD_Num_Entries)));
1432
1433       Append_To (Result,
1434         Make_Object_Declaration (Loc,
1435           Defining_Identifier => TSD,
1436           Aliased_Present     => True,
1437           Object_Definition   =>
1438             Make_Subtype_Indication (Loc,
1439               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
1440               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
1441                 Constraints => New_List (
1442                   Make_Range (Loc,
1443                     Low_Bound  => Make_Integer_Literal (Loc, 1),
1444                     High_Bound => Size_Expr_Node))))));
1445
1446       Append_To (Result,
1447         Make_Attribute_Definition_Clause (Loc,
1448           Name       => New_Reference_To (TSD, Loc),
1449           Chars      => Name_Alignment,
1450           Expression =>
1451             Make_Attribute_Reference (Loc,
1452               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
1453               Attribute_Name => Name_Alignment)));
1454
1455       --  Generate code to put the Address of the TSD in the dispatch table
1456       --    Set_TSD (DT_Ptr, TSD);
1457
1458       Append_To (Elab_Code,
1459         Make_DT_Access_Action (Typ,
1460           Action => Set_TSD,
1461           Args   => New_List (
1462             New_Reference_To (DT_Ptr, Loc),                  -- DTptr
1463               Make_Attribute_Reference (Loc,                 -- Value
1464               Prefix          => New_Reference_To (TSD, Loc),
1465               Attribute_Name  => Name_Address))));
1466
1467       --  Generate: Exname : constant String := full_qualified_name (typ);
1468       --  The type itself may be an anonymous parent type, so use the first
1469       --  subtype to have a user-recognizable name.
1470
1471       Append_To (Result,
1472         Make_Object_Declaration (Loc,
1473           Defining_Identifier => Exname,
1474           Constant_Present    => True,
1475           Object_Definition   => New_Reference_To (Standard_String, Loc),
1476           Expression =>
1477             Make_String_Literal (Loc,
1478               Full_Qualified_Name (First_Subtype (Typ)))));
1479
1480       --  Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
1481
1482       Append_To (Elab_Code,
1483         Make_DT_Access_Action (Typ,
1484           Action => Set_Expanded_Name,
1485           Args   => New_List (
1486             Node1 => New_Reference_To (DT_Ptr, Loc),
1487             Node2 =>
1488               Make_Attribute_Reference (Loc,
1489                 Prefix => New_Reference_To (Exname, Loc),
1490                 Attribute_Name => Name_Address))));
1491
1492       --  Generate: Set_Access_Level (DT_Ptr, <type's accessibility level>);
1493
1494       Append_To (Elab_Code,
1495         Make_DT_Access_Action (Typ,
1496           Action => Set_Access_Level,
1497           Args   => New_List (
1498             Node1 => New_Reference_To (DT_Ptr, Loc),
1499             Node2 => Make_Integer_Literal (Loc, Type_Access_Level (Typ)))));
1500
1501       --  Generate:
1502       --    Set_Offset_To_Top (DT_Ptr, 0);
1503
1504       Append_To (Elab_Code,
1505         Make_Procedure_Call_Statement (Loc,
1506           Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
1507           Parameter_Associations => New_List (
1508             New_Reference_To (DT_Ptr, Loc),
1509             Make_Integer_Literal (Loc, Uint_0))));
1510
1511       if Typ = Etype (Typ)
1512         or else Is_CPP_Class (Etype (Typ))
1513       then
1514          Old_Tag1 :=
1515            Unchecked_Convert_To (Generalized_Tag,
1516              Make_Integer_Literal (Loc, 0));
1517          Old_Tag2 :=
1518            Unchecked_Convert_To (Generalized_Tag,
1519              Make_Integer_Literal (Loc, 0));
1520
1521       else
1522          Old_Tag1 :=
1523            New_Reference_To
1524              (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
1525          Old_Tag2 :=
1526            New_Reference_To
1527              (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
1528       end if;
1529
1530       --  Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
1531
1532       Append_To (Elab_Code,
1533         Make_DT_Access_Action (Typ,
1534           Action => Inherit_DT,
1535           Args   => New_List (
1536             Node1 => Old_Tag1,
1537             Node2 => New_Reference_To (DT_Ptr, Loc),
1538             Node3 => Make_Integer_Literal (Loc,
1539                        DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
1540
1541       --  Generate: Inherit_TSD (parent'tag, DT_Ptr);
1542
1543       Append_To (Elab_Code,
1544         Make_DT_Access_Action (Typ,
1545           Action => Inherit_TSD,
1546           Args   => New_List (
1547             Node1 => Old_Tag2,
1548             Node2 => New_Reference_To (DT_Ptr, Loc))));
1549
1550       --  for types with no controlled components
1551       --    Generate: Set_RC_Offset (DT_Ptr, 0);
1552       --  for simple types with controlled components
1553       --    Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position);
1554       --  for complex types with controlled components where the position
1555       --  of the record controller is not statically computable, if there are
1556       --  controlled components at this level
1557       --    Generate: Set_RC_Offset (DT_Ptr, -1);
1558       --  to indicate that the _controller field is right after the _parent or
1559       --  if there are no controlled components at this level,
1560       --    Generate: Set_RC_Offset (DT_Ptr, -2);
1561       --  to indicate that we need to get the position from the parent.
1562
1563       declare
1564          Position : Node_Id;
1565
1566       begin
1567          if not Has_Controlled_Component (Typ) then
1568             Position := Make_Integer_Literal (Loc, 0);
1569
1570          elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then
1571             if Has_New_Controlled_Component (Typ) then
1572                Position := Make_Integer_Literal (Loc, -1);
1573             else
1574                Position := Make_Integer_Literal (Loc, -2);
1575             end if;
1576          else
1577             Position :=
1578               Make_Attribute_Reference (Loc,
1579                 Prefix =>
1580                   Make_Selected_Component (Loc,
1581                     Prefix => New_Reference_To (Typ, Loc),
1582                     Selector_Name =>
1583                       New_Reference_To (Controller_Component (Typ), Loc)),
1584                 Attribute_Name => Name_Position);
1585
1586             --  This is not proper Ada code to use the attribute 'Position
1587             --  on something else than an object but this is supported by
1588             --  the back end (see comment on the Bit_Component attribute in
1589             --  sem_attr). So we avoid semantic checking here.
1590
1591             Set_Analyzed (Position);
1592             Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
1593             Set_Etype (Prefix (Prefix (Position)), Typ);
1594             Set_Etype (Selector_Name (Prefix (Position)),
1595               RTE (RE_Record_Controller));
1596             Set_Etype (Position, RTE (RE_Storage_Offset));
1597          end if;
1598
1599          Append_To (Elab_Code,
1600            Make_DT_Access_Action (Typ,
1601              Action => Set_RC_Offset,
1602              Args   => New_List (
1603                Node1 => New_Reference_To (DT_Ptr, Loc),
1604                Node2 => Position)));
1605       end;
1606
1607       --  Generate: Set_Remotely_Callable (DT_Ptr, Status);
1608       --  where Status is described in E.4 (18)
1609
1610       declare
1611          Status : Entity_Id;
1612
1613       begin
1614          Status :=
1615            Boolean_Literals
1616              (Is_Pure (Typ)
1617                 or else Is_Shared_Passive (Typ)
1618                 or else
1619                   ((Is_Remote_Types (Typ)
1620                       or else Is_Remote_Call_Interface (Typ))
1621                    and then Original_View_In_Visible_Part (Typ))
1622                 or else not Comes_From_Source (Typ));
1623
1624          Append_To (Elab_Code,
1625            Make_DT_Access_Action (Typ,
1626              Action => Set_Remotely_Callable,
1627              Args   => New_List (
1628                New_Occurrence_Of (DT_Ptr, Loc),
1629                New_Occurrence_Of (Status, Loc))));
1630       end;
1631
1632       --  Generate: Set_External_Tag (DT_Ptr, exname'Address);
1633       --  Should be the external name not the qualified name???
1634
1635       if not Has_External_Tag_Rep_Clause (Typ) then
1636          Append_To (Elab_Code,
1637            Make_DT_Access_Action (Typ,
1638              Action => Set_External_Tag,
1639              Args   => New_List (
1640                Node1 => New_Reference_To (DT_Ptr, Loc),
1641                Node2 =>
1642                  Make_Attribute_Reference (Loc,
1643                    Prefix => New_Reference_To (Exname, Loc),
1644                    Attribute_Name => Name_Address))));
1645
1646       --  Generate code to register the Tag in the External_Tag hash
1647       --  table for the pure Ada type only.
1648
1649       --        Register_Tag (Dt_Ptr);
1650
1651       --  Skip this if routine not available, or in No_Run_Time mode
1652
1653          if RTE_Available (RE_Register_Tag)
1654            and then Is_RTE (Generalized_Tag, RE_Tag)
1655            and then not No_Run_Time_Mode
1656          then
1657             Append_To (Elab_Code,
1658               Make_Procedure_Call_Statement (Loc,
1659                 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
1660                 Parameter_Associations =>
1661                   New_List (New_Reference_To (DT_Ptr, Loc))));
1662          end if;
1663       end if;
1664
1665       --  Generate:
1666       --     if No_Reg then
1667       --        <elab_code>
1668       --        No_Reg := False;
1669       --     end if;
1670
1671       Append_To (Elab_Code,
1672         Make_Assignment_Statement (Loc,
1673           Name       => New_Reference_To (No_Reg, Loc),
1674           Expression => New_Reference_To (Standard_False, Loc)));
1675
1676       Append_To (Result,
1677         Make_Implicit_If_Statement (Typ,
1678           Condition       => New_Reference_To (No_Reg, Loc),
1679           Then_Statements => Elab_Code));
1680
1681       --  Ada 2005 (AI-251): Register the tag of the interfaces into
1682       --  the table of implemented interfaces
1683
1684       if Present (Abstract_Interfaces (Typ))
1685         and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
1686       then
1687          AI := First_Elmt (Abstract_Interfaces (Typ_Copy));
1688          while Present (AI) loop
1689
1690             --  Generate:
1691             --    Register_Interface (DT_Ptr, Interface'Tag);
1692
1693             Append_To (Result,
1694               Make_DT_Access_Action (Typ,
1695                 Action => Register_Interface_Tag,
1696                 Args   => New_List (
1697                   Node1 => New_Reference_To (DT_Ptr, Loc),
1698                   Node2 => New_Reference_To
1699                              (Node
1700                               (First_Elmt
1701                                (Access_Disp_Table (Node (AI)))),
1702                               Loc))));
1703
1704             Next_Elmt (AI);
1705          end loop;
1706       end if;
1707
1708       return Result;
1709    end Make_DT;
1710
1711    --------------------------------
1712    -- Make_Abstract_Interface_DT --
1713    --------------------------------
1714
1715    procedure Make_Abstract_Interface_DT
1716      (AI_Tag          : Entity_Id;
1717       Acc_Disp_Tables : in out Elist_Id;
1718       Result          : out List_Id)
1719    is
1720       Loc         : constant Source_Ptr := Sloc (AI_Tag);
1721       Tname       : constant Name_Id := Chars (AI_Tag);
1722       Name_DT     : constant Name_Id := New_External_Name (Tname, 'T');
1723       Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
1724
1725       Iface_DT     : constant Node_Id :=
1726                        Make_Defining_Identifier (Loc, Name_DT);
1727       Iface_DT_Ptr : constant Node_Id :=
1728                        Make_Defining_Identifier (Loc, Name_DT_Ptr);
1729
1730       Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
1731       Size_Expr_Node  : Node_Id;
1732       Nb_Prim         : Int;
1733
1734    begin
1735       Result := New_List;
1736
1737       --  Dispatch table and related entities are allocated statically
1738
1739       Set_Ekind (Iface_DT, E_Variable);
1740       Set_Is_Statically_Allocated (Iface_DT);
1741
1742       Set_Ekind (Iface_DT_Ptr, E_Variable);
1743       Set_Is_Statically_Allocated (Iface_DT_Ptr);
1744
1745       --  Generate code to create the storage for the Dispatch_Table object
1746
1747       --    DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
1748       --    for DT'Alignment use Address'Alignment
1749
1750       Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
1751
1752       Size_Expr_Node :=
1753         Make_Op_Add (Loc,
1754           Left_Opnd  => Make_DT_Access_Action (Etype (AI_Tag),
1755                           DT_Prologue_Size,
1756                           No_List),
1757           Right_Opnd =>
1758             Make_Op_Multiply (Loc,
1759               Left_Opnd  =>
1760                 Make_DT_Access_Action (Etype (AI_Tag),
1761                                        DT_Entry_Size,
1762                                        No_List),
1763               Right_Opnd =>
1764                 Make_Integer_Literal (Loc, Nb_Prim)));
1765
1766       Append_To (Result,
1767         Make_Object_Declaration (Loc,
1768           Defining_Identifier => Iface_DT,
1769           Aliased_Present     => True,
1770           Object_Definition   =>
1771             Make_Subtype_Indication (Loc,
1772               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
1773               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
1774                 Constraints => New_List (
1775                   Make_Range (Loc,
1776                     Low_Bound  => Make_Integer_Literal (Loc, 1),
1777                     High_Bound => Size_Expr_Node)))),
1778
1779             --  Initialize the signature of the interface tag. It is currently
1780             --  a sequence of four bytes located in the unused Typeinfo_Ptr
1781             --  field of the prologue). Its current value is the following
1782             --  sequence: (80, Nb_Prim, 0, 80)
1783
1784           Expression =>
1785             Make_Aggregate (Loc,
1786               Component_Associations => New_List (
1787                 Make_Component_Association (Loc,
1788
1789                   --  -80, 0, 0, -80
1790
1791                   Choices => New_List (
1792                     Make_Integer_Literal (Loc, Uint_5),
1793                     Make_Integer_Literal (Loc, Uint_8)),
1794                   Expression =>
1795                     Make_Integer_Literal (Loc, Uint_80)),
1796
1797                 Make_Component_Association (Loc,
1798                   Choices => New_List (
1799                     Make_Integer_Literal (Loc, Uint_2)),
1800                   Expression =>
1801                     Make_Integer_Literal (Loc, Nb_Prim)),
1802
1803                 Make_Component_Association (Loc,
1804                   Choices => New_List (
1805                     Make_Others_Choice (Loc)),
1806                   Expression => Make_Integer_Literal (Loc, Uint_0))))));
1807
1808       Append_To (Result,
1809         Make_Attribute_Definition_Clause (Loc,
1810           Name       => New_Reference_To (Iface_DT, Loc),
1811           Chars      => Name_Alignment,
1812           Expression =>
1813             Make_Attribute_Reference (Loc,
1814               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
1815               Attribute_Name => Name_Alignment)));
1816
1817       --  Generate code to create the pointer to the dispatch table
1818
1819       --    Iface_DT_Ptr : Tag := Tag!(DT'Address);
1820
1821       --  According to the C++ ABI, the base of the vtable is located
1822       --  after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
1823       --  Hence, move the pointer down to the real base of the vtable.
1824
1825       Append_To (Result,
1826         Make_Object_Declaration (Loc,
1827           Defining_Identifier => Iface_DT_Ptr,
1828           Constant_Present    => True,
1829           Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
1830           Expression          =>
1831             Unchecked_Convert_To (Generalized_Tag,
1832               Make_Op_Add (Loc,
1833                 Left_Opnd =>
1834                   Unchecked_Convert_To (RTE (RE_Storage_Offset),
1835                     Make_Attribute_Reference (Loc,
1836                       Prefix         => New_Reference_To (Iface_DT, Loc),
1837                       Attribute_Name => Name_Address)),
1838                 Right_Opnd =>
1839                   Make_DT_Access_Action (Etype (AI_Tag),
1840                     DT_Prologue_Size, No_List)))));
1841
1842       --  Note: Offset_To_Top will be initialized by the init subprogram
1843
1844       --  Set Access_Disp_Table field to be the dispatch table pointer
1845
1846       if not (Present (Acc_Disp_Tables)) then
1847          Acc_Disp_Tables := New_Elmt_List;
1848       end if;
1849
1850       Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
1851
1852    end Make_Abstract_Interface_DT;
1853
1854    ---------------------------
1855    -- Make_DT_Access_Action --
1856    ---------------------------
1857
1858    function Make_DT_Access_Action
1859      (Typ    : Entity_Id;
1860       Action : DT_Access_Action;
1861       Args   : List_Id) return Node_Id
1862    is
1863       Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
1864       Loc         : Source_Ptr;
1865
1866    begin
1867       if No (Args) then
1868
1869          --  This is a constant
1870
1871          return New_Reference_To (Action_Name, Sloc (Typ));
1872       end if;
1873
1874       pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
1875
1876       Loc := Sloc (First (Args));
1877
1878       if Action_Is_Proc (Action) then
1879          return
1880            Make_Procedure_Call_Statement (Loc,
1881              Name => New_Reference_To (Action_Name, Loc),
1882              Parameter_Associations => Args);
1883
1884       else
1885          return
1886            Make_Function_Call (Loc,
1887              Name => New_Reference_To (Action_Name, Loc),
1888              Parameter_Associations => Args);
1889       end if;
1890    end Make_DT_Access_Action;
1891
1892    -----------------------------------
1893    -- Original_View_In_Visible_Part --
1894    -----------------------------------
1895
1896    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
1897       Scop : constant Entity_Id := Scope (Typ);
1898
1899    begin
1900       --  The scope must be a package
1901
1902       if Ekind (Scop) /= E_Package
1903         and then Ekind (Scop) /= E_Generic_Package
1904       then
1905          return False;
1906       end if;
1907
1908       --  A type with a private declaration has a private view declared in
1909       --  the visible part.
1910
1911       if Has_Private_Declaration (Typ) then
1912          return True;
1913       end if;
1914
1915       return List_Containing (Parent (Typ)) =
1916         Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
1917    end Original_View_In_Visible_Part;
1918
1919    -------------------------
1920    -- Set_All_DT_Position --
1921    -------------------------
1922
1923    procedure Set_All_DT_Position (Typ : Entity_Id) is
1924       Parent_Typ : constant Entity_Id := Etype (Typ);
1925       Root_Typ   : constant Entity_Id := Root_Type (Typ);
1926       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
1927       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
1928
1929       Adjusted   : Boolean := False;
1930       Finalized  : Boolean := False;
1931
1932       Count_Prim : Int;
1933       DT_Length  : Int;
1934       Nb_Prim    : Int;
1935       Parent_EC  : Int;
1936       Prim       : Entity_Id;
1937       Prim_Elmt  : Elmt_Id;
1938
1939       procedure Validate_Position (Prim : Entity_Id);
1940       --  Check that the position assignated to Prim is completely safe
1941       --  (it has not been assigned to a previously defined primitive
1942       --   operation of Typ)
1943
1944       -----------------------
1945       -- Validate_Position --
1946       -----------------------
1947
1948       procedure Validate_Position (Prim : Entity_Id) is
1949          Prim_Elmt : Elmt_Id;
1950       begin
1951          Prim_Elmt :=  First_Elmt (Primitive_Operations (Typ));
1952          while Present (Prim_Elmt)
1953             and then Node (Prim_Elmt) /= Prim
1954          loop
1955             --  Primitive operations covering abstract interfaces are
1956             --  allocated later
1957
1958             if Present (Abstract_Interface_Alias (Node (Prim_Elmt))) then
1959                null;
1960
1961             --  Predefined dispatching operations are completely safe.
1962             --  They are allocated at fixed positions.
1963
1964             elsif Is_Predefined_Dispatching_Operation (Node (Prim_Elmt)) then
1965                null;
1966
1967             --  Aliased subprograms are safe
1968
1969             elsif Present (Alias (Prim)) then
1970                null;
1971
1972             elsif DT_Position (Node (Prim_Elmt)) = DT_Position (Prim) then
1973                raise Program_Error;
1974             end if;
1975
1976             Next_Elmt (Prim_Elmt);
1977          end loop;
1978       end Validate_Position;
1979
1980    --  Start of processing for Set_All_DT_Position
1981
1982    begin
1983       --  Get Entry_Count of the parent
1984
1985       if Parent_Typ /= Typ
1986         and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
1987       then
1988          Parent_EC := UI_To_Int (DT_Entry_Count
1989                                    (First_Tag_Component (Parent_Typ)));
1990       else
1991          Parent_EC := 0;
1992       end if;
1993
1994       --  C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
1995       --  give a coherent set of information
1996
1997       if Is_CPP_Class (Root_Typ) then
1998
1999          --  Compute the number of primitive operations in the main Vtable
2000          --  Set their position:
2001          --    - where it was set if overriden or inherited
2002          --    - after the end of the parent vtable otherwise
2003
2004          Prim_Elmt := First_Prim;
2005          Nb_Prim := 0;
2006          while Present (Prim_Elmt) loop
2007             Prim := Node (Prim_Elmt);
2008
2009             if not Is_CPP_Class (Typ) then
2010                Set_DTC_Entity (Prim, The_Tag);
2011
2012             elsif Present (Alias (Prim)) then
2013                Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
2014                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
2015
2016             elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
2017                   Error_Msg_NE ("is a primitive operation of&," &
2018                     " pragma Cpp_Virtual required", Prim, Typ);
2019             end if;
2020
2021             if DTC_Entity (Prim) = The_Tag then
2022
2023                --  Get the slot from the parent subprogram if any
2024
2025                declare
2026                   H : Entity_Id := Homonym (Prim);
2027
2028                begin
2029                   while Present (H) loop
2030                      if Present (DTC_Entity (H))
2031                        and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
2032                      then
2033                         Set_DT_Position (Prim, DT_Position (H));
2034                         exit;
2035                      end if;
2036
2037                      H := Homonym (H);
2038                   end loop;
2039                end;
2040
2041                --  Otherwise take the canonical slot after the end of the
2042                --  parent Vtable
2043
2044                if DT_Position (Prim) = No_Uint then
2045                   Nb_Prim := Nb_Prim + 1;
2046                   Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
2047
2048                elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
2049                   Nb_Prim := Nb_Prim + 1;
2050                end if;
2051             end if;
2052
2053             Next_Elmt (Prim_Elmt);
2054          end loop;
2055
2056          --  Check that the declared size of the Vtable is bigger or equal
2057          --  than the number of primitive operations (if bigger it means that
2058          --  some of the c++ virtual functions were not imported, that is
2059          --  allowed)
2060
2061          if DT_Entry_Count (The_Tag) = No_Uint
2062            or else not Is_CPP_Class (Typ)
2063          then
2064             Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
2065
2066          elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
2067             Error_Msg_N ("not enough room in the Vtable for all virtual"
2068               & " functions", The_Tag);
2069          end if;
2070
2071          --  Check that Positions are not duplicate nor outside the range of
2072          --  the Vtable
2073
2074          declare
2075             Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
2076             Pos  : Int;
2077             Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
2078                                                         (others => Empty);
2079
2080          begin
2081             Prim_Elmt := First_Prim;
2082             while Present (Prim_Elmt) loop
2083                Prim := Node (Prim_Elmt);
2084
2085                if DTC_Entity (Prim) = The_Tag then
2086                   Pos := UI_To_Int (DT_Position (Prim));
2087
2088                   if Pos not in Prim_Pos_Table'Range then
2089                      Error_Msg_N
2090                        ("position not in range of virtual table", Prim);
2091
2092                   elsif Present (Prim_Pos_Table (Pos)) then
2093                      Error_Msg_NE ("cannot be at the same position in the"
2094                        & " vtable than&", Prim, Prim_Pos_Table (Pos));
2095
2096                   else
2097                      Prim_Pos_Table (Pos) := Prim;
2098                   end if;
2099                end if;
2100
2101                Next_Elmt (Prim_Elmt);
2102             end loop;
2103          end;
2104
2105       --  For regular Ada tagged types, just set the DT_Position for
2106       --  each primitive operation. Perform some sanity checks to avoid
2107       --  to build completely inconsistant dispatch tables.
2108
2109       --  Note that the _Size primitive is always set at position 1 in order
2110       --  to comply with the needs of Ada.Tags.Parent_Size (see documentation
2111       --  in a-tags.ad?)
2112
2113       else
2114          --  First stage: Set the DTC entity of all the primitive operations
2115          --  This is required to properly read the DT_Position attribute in
2116          --  the latter stages.
2117
2118          Prim_Elmt  := First_Prim;
2119          Count_Prim := 0;
2120          while Present (Prim_Elmt) loop
2121             Count_Prim := Count_Prim + 1;
2122             Prim       := Node (Prim_Elmt);
2123
2124             --  Ada 2005 (AI-251)
2125
2126             if Present (Abstract_Interface_Alias (Prim)) then
2127                Set_DTC_Entity (Prim,
2128                   Find_Interface_Tag
2129                     (T => Typ,
2130                      Iface => Scope (DTC_Entity
2131                                       (Abstract_Interface_Alias (Prim)))));
2132
2133             else
2134                Set_DTC_Entity (Prim, The_Tag);
2135             end if;
2136
2137             --  Clear any previous value of the DT_Position attribute. In this
2138             --  way we ensure that the final position of all the primitives is
2139             --  stablished by the following stages of this algorithm.
2140
2141             Set_DT_Position (Prim, No_Uint);
2142
2143             Next_Elmt (Prim_Elmt);
2144          end loop;
2145
2146          declare
2147             Fixed_Prim : array (Int range 0 .. 10 + Parent_EC + Count_Prim)
2148                             of Boolean := (others => False);
2149             E          : Entity_Id;
2150
2151          begin
2152             --  Second stage: Register fixed entries
2153
2154             Nb_Prim   := 10;
2155             Prim_Elmt := First_Prim;
2156
2157             while Present (Prim_Elmt) loop
2158                Prim := Node (Prim_Elmt);
2159
2160                --  Predefined primitives have a fixed position in all the
2161                --  dispatch tables
2162
2163                if Is_Predefined_Dispatching_Operation (Prim) then
2164                   Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
2165                   Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
2166
2167                --  Overriding interface primitives of an ancestor
2168
2169                elsif DT_Position (Prim) = No_Uint
2170                  and then Present (Abstract_Interface_Alias (Prim))
2171                  and then Present (DTC_Entity
2172                                    (Abstract_Interface_Alias (Prim)))
2173                  and then DT_Position (Abstract_Interface_Alias (Prim))
2174                                         /= No_Uint
2175                  and then Is_Inherited_Operation (Prim)
2176                  and then Is_Ancestor (Scope
2177                                        (DTC_Entity
2178                                         (Abstract_Interface_Alias (Prim))),
2179                                        Typ)
2180                then
2181                   Set_DT_Position (Prim,
2182                     DT_Position (Abstract_Interface_Alias (Prim)));
2183                   Set_DT_Position (Alias (Prim),
2184                     DT_Position (Abstract_Interface_Alias (Prim)));
2185                   Fixed_Prim (UI_To_Int (DT_Position (Prim))) := True;
2186
2187                --  Overriding primitives must use the same entry as the
2188                --  overriden primitive
2189
2190                elsif DT_Position (Prim) = No_Uint
2191                  and then Present (Alias (Prim))
2192                  and then Present (DTC_Entity (Alias (Prim)))
2193                  and then DT_Position (Alias (Prim)) /= No_Uint
2194                  and then Is_Inherited_Operation (Prim)
2195                  and then Is_Ancestor (Scope (DTC_Entity (Alias (Prim))), Typ)
2196                then
2197                   E := Alias (Prim);
2198                   while not (Present (DTC_Entity (E))
2199                               or else DT_Position (E) = No_Uint)
2200                     and then Present (Alias (E))
2201                   loop
2202                      E := Alias (E);
2203                   end loop;
2204
2205                   pragma Assert (Present (DTC_Entity (E))
2206                                    and then
2207                                  DT_Position (E) /= No_Uint);
2208
2209                   Set_DT_Position (Prim, DT_Position (E));
2210                   Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
2211
2212                   --  If this is not the last element in the chain continue
2213                   --  traversing the chain. This is required to properly
2214                   --  handling renamed primitives
2215
2216                   if Present (Alias (E)) then
2217                      while Present (Alias (E)) loop
2218                         E   := Alias (E);
2219                         Fixed_Prim (UI_To_Int (DT_Position (E))) := True;
2220                      end loop;
2221                   end if;
2222                end if;
2223
2224                Next_Elmt (Prim_Elmt);
2225             end loop;
2226
2227             --  Third stage: Fix the position of all the new primitives
2228             --  Entries associated with primitives covering interfaces
2229             --  are handled in a latter round.
2230
2231             Prim_Elmt := First_Prim;
2232             while Present (Prim_Elmt) loop
2233                Prim := Node (Prim_Elmt);
2234
2235                --  Skip primitives previously set entries
2236
2237                if DT_Position (Prim) /= No_Uint then
2238                   null;
2239
2240                elsif Etype (DTC_Entity (Prim)) /= RTE (RE_Tag) then
2241                   null;
2242
2243                --  Primitives covering interface primitives are
2244                --  handled later
2245
2246                elsif Present (Abstract_Interface_Alias (Prim)) then
2247                   null;
2248
2249                else
2250                   --  Take the next available position in the DT
2251
2252                   loop
2253                      Nb_Prim := Nb_Prim + 1;
2254                      exit when not Fixed_Prim (Nb_Prim);
2255                   end loop;
2256
2257                   Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
2258                   Fixed_Prim (Nb_Prim) := True;
2259                end if;
2260
2261                Next_Elmt (Prim_Elmt);
2262             end loop;
2263          end;
2264
2265          --  Fourth stage: Complete the decoration of primitives covering
2266          --  interfaces (that is, propagate the DT_Position attribute
2267          --  from the aliased primitive)
2268
2269          Prim_Elmt := First_Prim;
2270          while Present (Prim_Elmt) loop
2271             Prim := Node (Prim_Elmt);
2272
2273             if DT_Position (Prim) = No_Uint
2274                and then Present (Abstract_Interface_Alias (Prim))
2275             then
2276                --  Check if this entry will be placed in the primary DT
2277
2278                if Etype (DTC_Entity (Abstract_Interface_Alias (Prim)))
2279                     = RTE (RE_Tag)
2280                then
2281                   pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
2282                   Set_DT_Position (Prim, DT_Position (Alias (Prim)));
2283
2284                --  Otherwise it will be placed in the secondary DT
2285
2286                else
2287                   pragma Assert
2288                     (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
2289
2290                   Set_DT_Position (Prim,
2291                      DT_Position (Abstract_Interface_Alias (Prim)));
2292                end if;
2293             end if;
2294
2295             Next_Elmt (Prim_Elmt);
2296          end loop;
2297
2298          --  Final stage: Ensure that the table is correct plus some further
2299          --  verifications concerning the primitives.
2300
2301          Prim_Elmt := First_Prim;
2302          DT_Length := 0;
2303
2304          while Present (Prim_Elmt) loop
2305             Prim := Node (Prim_Elmt);
2306
2307             --  At this point all the primitives MUST have a position
2308             --  in the dispatch table
2309
2310             if DT_Position (Prim) = No_Uint then
2311                raise Program_Error;
2312             end if;
2313
2314             --  Calculate real size of the dispatch table
2315
2316             if UI_To_Int (DT_Position (Prim)) > DT_Length then
2317                DT_Length := UI_To_Int (DT_Position (Prim));
2318             end if;
2319
2320             --  Ensure that the asignated position in the dispatch
2321             --  table is correct
2322
2323             Validate_Position (Prim);
2324
2325             if Chars (Prim) = Name_Finalize then
2326                Finalized := True;
2327             end if;
2328
2329             if Chars (Prim) = Name_Adjust then
2330                Adjusted := True;
2331             end if;
2332
2333             --  An abstract operation cannot be declared in the private part
2334             --  for a visible abstract type, because it could never be over-
2335             --  ridden. For explicit declarations this is checked at the
2336             --  point of declaration, but for inherited operations it must
2337             --  be done when building the dispatch table. Input is excluded
2338             --  because
2339
2340             if Is_Abstract (Typ)
2341               and then Is_Abstract (Prim)
2342               and then Present (Alias (Prim))
2343               and then Is_Derived_Type (Typ)
2344               and then In_Private_Part (Current_Scope)
2345               and then
2346                 List_Containing (Parent (Prim)) =
2347                   Private_Declarations
2348                    (Specification (Unit_Declaration_Node (Current_Scope)))
2349               and then Original_View_In_Visible_Part (Typ)
2350             then
2351                --  We exclude Input and Output stream operations because
2352                --  Limited_Controlled inherits useless Input and Output
2353                --  stream operations from Root_Controlled, which can
2354                --  never be overridden.
2355
2356                if not Is_TSS (Prim, TSS_Stream_Input)
2357                     and then
2358                   not Is_TSS (Prim, TSS_Stream_Output)
2359                then
2360                   Error_Msg_NE
2361                     ("abstract inherited private operation&" &
2362                      " must be overridden ('R'M 3.9.3(10))",
2363                     Parent (Typ), Prim);
2364                end if;
2365             end if;
2366
2367             Next_Elmt (Prim_Elmt);
2368          end loop;
2369
2370          --  Additional check
2371
2372          if Is_Controlled (Typ) then
2373             if not Finalized then
2374                Error_Msg_N
2375                  ("controlled type has no explicit Finalize method?", Typ);
2376
2377             elsif not Adjusted then
2378                Error_Msg_N
2379                  ("controlled type has no explicit Adjust method?", Typ);
2380             end if;
2381          end if;
2382
2383          --  Set the final size of the Dispatch Table
2384
2385          Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
2386
2387          --  The derived type must have at least as many components as its
2388          --  parent (for root types, the Etype points back to itself
2389          --  and the test should not fail)
2390
2391          --  This test fails compiling the partial view of a tagged type
2392          --  derived from an interface which defines the overriding subprogram
2393          --  in the private part. This needs further investigation???
2394
2395          if not Has_Private_Declaration (Typ) then
2396             pragma Assert (
2397               DT_Entry_Count (The_Tag) >=
2398               DT_Entry_Count (First_Tag_Component (Parent_Typ)));
2399             null;
2400          end if;
2401       end if;
2402
2403       if Debug_Flag_ZZ then
2404          Write_DT (Typ);
2405       end if;
2406    end Set_All_DT_Position;
2407
2408    -----------------------------
2409    -- Set_Default_Constructor --
2410    -----------------------------
2411
2412    procedure Set_Default_Constructor (Typ : Entity_Id) is
2413       Loc   : Source_Ptr;
2414       Init  : Entity_Id;
2415       Param : Entity_Id;
2416       E     : Entity_Id;
2417
2418    begin
2419       --  Look for the default constructor entity. For now only the
2420       --  default constructor has the flag Is_Constructor.
2421
2422       E := Next_Entity (Typ);
2423       while Present (E)
2424         and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
2425       loop
2426          Next_Entity (E);
2427       end loop;
2428
2429       --  Create the init procedure
2430
2431       if Present (E) then
2432          Loc   := Sloc (E);
2433          Init  := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
2434          Param := Make_Defining_Identifier (Loc, Name_X);
2435
2436          Discard_Node (
2437            Make_Subprogram_Declaration (Loc,
2438              Make_Procedure_Specification (Loc,
2439                Defining_Unit_Name => Init,
2440                Parameter_Specifications => New_List (
2441                  Make_Parameter_Specification (Loc,
2442                    Defining_Identifier => Param,
2443                    Parameter_Type      => New_Reference_To (Typ, Loc))))));
2444
2445          Set_Init_Proc (Typ, Init);
2446          Set_Is_Imported    (Init);
2447          Set_Interface_Name (Init, Interface_Name (E));
2448          Set_Convention     (Init, Convention_C);
2449          Set_Is_Public      (Init);
2450          Set_Has_Completion (Init);
2451
2452       --  If there are no constructors, mark the type as abstract since we
2453       --  won't be able to declare objects of that type.
2454
2455       else
2456          Set_Is_Abstract (Typ);
2457       end if;
2458    end Set_Default_Constructor;
2459
2460    --------------
2461    -- Write_DT --
2462    --------------
2463
2464    procedure Write_DT (Typ : Entity_Id) is
2465       Elmt : Elmt_Id;
2466       Prim : Node_Id;
2467
2468    begin
2469       --  Protect this procedure against wrong usage. Required because it will
2470       --  be used directly from GDB
2471
2472       if not (Typ in First_Node_Id .. Last_Node_Id)
2473         or else not Is_Tagged_Type (Typ)
2474       then
2475          Write_Str ("wrong usage: write_dt must be used with tagged types");
2476          Write_Eol;
2477          return;
2478       end if;
2479
2480       Write_Int (Int (Typ));
2481       Write_Str (": ");
2482       Write_Name (Chars (Typ));
2483
2484       if Is_Interface (Typ) then
2485          Write_Str (" is interface");
2486       end if;
2487
2488       Write_Eol;
2489
2490       Elmt := First_Elmt (Primitive_Operations (Typ));
2491       while Present (Elmt) loop
2492          Prim := Node (Elmt);
2493          Write_Str  (" - ");
2494
2495          --  Indicate if this primitive will be allocated in the primary
2496          --  dispatch table or in a secondary dispatch table associated
2497          --  with an abstract interface type
2498
2499          if Present (DTC_Entity (Prim)) then
2500             if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
2501                Write_Str ("[P] ");
2502             else
2503                Write_Str ("[s] ");
2504             end if;
2505          end if;
2506
2507          --  Output the node of this primitive operation and its name
2508
2509          Write_Int  (Int (Prim));
2510          Write_Str  (": ");
2511          Write_Name (Chars (Prim));
2512
2513          --  Indicate if this primitive has an aliased primitive
2514
2515          if Present (Alias (Prim)) then
2516             Write_Str (" (alias = ");
2517             Write_Int (Int (Alias (Prim)));
2518
2519             --  If the DTC_Entity attribute is already set we can also output
2520             --  the name of the interface covered by this primitive (if any)
2521
2522             if Present (DTC_Entity (Alias (Prim)))
2523               and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
2524             then
2525                Write_Str  (" from interface ");
2526                Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
2527             end if;
2528
2529             if Present (Abstract_Interface_Alias (Prim)) then
2530                Write_Str  (", AI_Alias of ");
2531                Write_Name (Chars (Scope (DTC_Entity
2532                                           (Abstract_Interface_Alias (Prim)))));
2533                Write_Char (':');
2534                Write_Int  (Int (Abstract_Interface_Alias (Prim)));
2535             end if;
2536
2537             Write_Str (")");
2538          end if;
2539
2540          --  Display the final position of this primitive in its associated
2541          --  (primary or secondary) dispatch table
2542
2543          if Present (DTC_Entity (Prim))
2544            and then DT_Position (Prim) /= No_Uint
2545          then
2546             Write_Str (" at #");
2547             Write_Int (UI_To_Int (DT_Position (Prim)));
2548          end if;
2549
2550          if Is_Abstract (Prim) then
2551             Write_Str (" is abstract;");
2552          end if;
2553
2554          Write_Eol;
2555
2556          Next_Elmt (Elmt);
2557       end loop;
2558    end Write_DT;
2559
2560 end Exp_Disp;