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-2006, 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_Atag; use Exp_Atag;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Exp_Dbug; use Exp_Dbug;
  36 with Exp_Tss;  use Exp_Tss;
  37 with Exp_Util; use Exp_Util;
  38 with Freeze;   use Freeze;
  39 with Itypes;   use Itypes;
  40 with Nlists;   use Nlists;
  41 with Nmake;    use Nmake;
  42 with Namet;    use Namet;
  43 with Opt;      use Opt;
  44 with Output;   use Output;
  45 with Restrict; use Restrict;
  46 with Rident;   use Rident;
  47 with Rtsfind;  use Rtsfind;
  48 with Sem;      use Sem;
  49 with Sem_Disp; use Sem_Disp;
  50 with Sem_Res;  use Sem_Res;
  51 with Sem_Type; use Sem_Type;
  52 with Sem_Util; use Sem_Util;
  53 with Sinfo;    use Sinfo;
  54 with Snames;   use Snames;
  55 with Stand;    use Stand;
  56 with Tbuild;   use Tbuild;
  57 with Uintp;    use Uintp;
  58
  59 package body Exp_Disp is
  60
  61    --------------------------------
  62    -- Select_Expansion_Utilities --
  63    --------------------------------
  64
  65    --  The following package contains helper routines used in the expansion of
  66    --  dispatching asynchronous, conditional and timed selects.
  67
  68    package Select_Expansion_Utilities is
  69       procedure Build_B
  70         (Loc    : Source_Ptr;
  71          Params : List_Id);
  72       --  Generate:
  73       --    B : out Communication_Block
  74
  75       procedure Build_C
  76         (Loc    : Source_Ptr;
  77          Params : List_Id);
  78       --  Generate:
  79       --    C : out Prim_Op_Kind
  80
  81       procedure Build_Common_Dispatching_Select_Statements
  82         (Loc    : Source_Ptr;
  83          Typ    : Entity_Id;
  84          DT_Ptr : Entity_Id;
  85          Stmts  : List_Id);
  86       --  Ada 2005 (AI-345): Generate statements that are common between
  87       --  asynchronous, conditional and timed select expansion.
  88
  89       procedure Build_F
  90         (Loc    : Source_Ptr;
  91          Params : List_Id);
  92       --  Generate:
  93       --    F : out Boolean
  94
  95       procedure Build_P
  96         (Loc    : Source_Ptr;
  97          Params : List_Id);
  98       --  Generate:
  99       --    P : Address
 100
 101       procedure Build_S
 102         (Loc    : Source_Ptr;
 103          Params : List_Id);
 104       --  Generate:
 105       --    S : Integer
 106
 107       procedure Build_T
 108         (Loc    : Source_Ptr;
 109          Typ    : Entity_Id;
 110          Params : List_Id);
 111       --  Generate:
 112       --    T : in out Typ
 113    end Select_Expansion_Utilities;
 114
 115    package body Select_Expansion_Utilities is
 116
 117       -------------
 118       -- Build_B --
 119       -------------
 120
 121       procedure Build_B
 122         (Loc    : Source_Ptr;
 123          Params : List_Id)
 124       is
 125       begin
 126          Append_To (Params,
 127            Make_Parameter_Specification (Loc,
 128              Defining_Identifier =>
 129                Make_Defining_Identifier (Loc, Name_uB),
 130              Parameter_Type =>
 131                New_Reference_To (RTE (RE_Communication_Block), Loc),
 132              Out_Present => True));
 133       end Build_B;
 134
 135       -------------
 136       -- Build_C --
 137       -------------
 138
 139       procedure Build_C
 140         (Loc    : Source_Ptr;
 141          Params : List_Id)
 142       is
 143       begin
 144          Append_To (Params,
 145            Make_Parameter_Specification (Loc,
 146              Defining_Identifier =>
 147                Make_Defining_Identifier (Loc, Name_uC),
 148              Parameter_Type =>
 149                New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
 150              Out_Present => True));
 151       end Build_C;
 152
 153       ------------------------------------------------
 154       -- Build_Common_Dispatching_Select_Statements --
 155       ------------------------------------------------
 156
 157       procedure Build_Common_Dispatching_Select_Statements
 158         (Loc    : Source_Ptr;
 159          Typ    : Entity_Id;
 160          DT_Ptr : Entity_Id;
 161          Stmts  : List_Id)
 162       is
 163       begin
 164          --  Generate:
 165          --    C := get_prim_op_kind (tag! (<type>VP), S);
 166
 167          --  where C is the out parameter capturing the call kind and S is the
 168          --  dispatch table slot number.
 169
 170          Append_To (Stmts,
 171            Make_Assignment_Statement (Loc,
 172              Name =>
 173                Make_Identifier (Loc, Name_uC),
 174              Expression =>
 175                Make_DT_Access_Action (Typ,
 176                  Action =>
 177                    Get_Prim_Op_Kind,
 178                  Args =>
 179                    New_List (
 180                      Unchecked_Convert_To (RTE (RE_Tag),
 181                        New_Reference_To (DT_Ptr, Loc)),
 182                      Make_Identifier (Loc, Name_uS)))));
 183
 184          --  Generate:
 185
 186          --    if C = POK_Procedure
 187          --      or else C = POK_Protected_Procedure
 188          --      or else C = POK_Task_Procedure;
 189          --    then
 190          --       F := True;
 191          --       return;
 192
 193          --  where F is the out parameter capturing the status of a potential
 194          --  entry call.
 195
 196          Append_To (Stmts,
 197            Make_If_Statement (Loc,
 198
 199              Condition =>
 200                Make_Or_Else (Loc,
 201                  Left_Opnd =>
 202                    Make_Op_Eq (Loc,
 203                      Left_Opnd =>
 204                        Make_Identifier (Loc, Name_uC),
 205                      Right_Opnd =>
 206                        New_Reference_To (RTE (RE_POK_Procedure), Loc)),
 207                  Right_Opnd =>
 208                    Make_Or_Else (Loc,
 209                      Left_Opnd =>
 210                        Make_Op_Eq (Loc,
 211                          Left_Opnd =>
 212                            Make_Identifier (Loc, Name_uC),
 213                          Right_Opnd =>
 214                            New_Reference_To (RTE (
 215                              RE_POK_Protected_Procedure), Loc)),
 216                      Right_Opnd =>
 217                        Make_Op_Eq (Loc,
 218                          Left_Opnd =>
 219                            Make_Identifier (Loc, Name_uC),
 220                          Right_Opnd =>
 221                            New_Reference_To (RTE (
 222                              RE_POK_Task_Procedure), Loc)))),
 223
 224              Then_Statements =>
 225                New_List (
 226                  Make_Assignment_Statement (Loc,
 227                    Name       => Make_Identifier (Loc, Name_uF),
 228                    Expression => New_Reference_To (Standard_True, Loc)),
 229
 230                  Make_Return_Statement (Loc))));
 231       end Build_Common_Dispatching_Select_Statements;
 232
 233       -------------
 234       -- Build_F --
 235       -------------
 236
 237       procedure Build_F
 238         (Loc    : Source_Ptr;
 239          Params : List_Id)
 240       is
 241       begin
 242          Append_To (Params,
 243            Make_Parameter_Specification (Loc,
 244              Defining_Identifier =>
 245                Make_Defining_Identifier (Loc, Name_uF),
 246              Parameter_Type =>
 247                New_Reference_To (Standard_Boolean, Loc),
 248              Out_Present => True));
 249       end Build_F;
 250
 251       -------------
 252       -- Build_P --
 253       -------------
 254
 255       procedure Build_P
 256         (Loc    : Source_Ptr;
 257          Params : List_Id)
 258       is
 259       begin
 260          Append_To (Params,
 261            Make_Parameter_Specification (Loc,
 262              Defining_Identifier =>
 263                Make_Defining_Identifier (Loc, Name_uP),
 264              Parameter_Type =>
 265                New_Reference_To (RTE (RE_Address), Loc)));
 266       end Build_P;
 267
 268       -------------
 269       -- Build_S --
 270       -------------
 271
 272       procedure Build_S
 273         (Loc    : Source_Ptr;
 274          Params : List_Id)
 275       is
 276       begin
 277          Append_To (Params,
 278            Make_Parameter_Specification (Loc,
 279              Defining_Identifier =>
 280                Make_Defining_Identifier (Loc, Name_uS),
 281              Parameter_Type =>
 282                New_Reference_To (Standard_Integer, Loc)));
 283       end Build_S;
 284
 285       -------------
 286       -- Build_T --
 287       -------------
 288
 289       procedure Build_T
 290         (Loc    : Source_Ptr;
 291          Typ    : Entity_Id;
 292          Params : List_Id)
 293       is
 294       begin
 295          Append_To (Params,
 296            Make_Parameter_Specification (Loc,
 297              Defining_Identifier =>
 298                Make_Defining_Identifier (Loc, Name_uT),
 299              Parameter_Type =>
 300                New_Reference_To (Typ, Loc),
 301              In_Present  => True,
 302              Out_Present => True));
 303       end Build_T;
 304    end Select_Expansion_Utilities;
 305
 306    package SEU renames Select_Expansion_Utilities;
 307
 308    Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
 309       (IW_Membership                  => RE_IW_Membership,
 310        Get_Entry_Index                => RE_Get_Entry_Index,
 311        Get_Prim_Op_Kind               => RE_Get_Prim_Op_Kind,
 312        Get_Tagged_Kind                => RE_Get_Tagged_Kind,
 313        Register_Interface_Tag         => RE_Register_Interface_Tag,
 314        Register_Tag                   => RE_Register_Tag,
 315        Set_Entry_Index                => RE_Set_Entry_Index,
 316        Set_Offset_Index               => RE_Set_Offset_Index,
 317        Set_OSD                        => RE_Set_OSD,
 318        Set_Prim_Op_Kind               => RE_Set_Prim_Op_Kind,
 319        Set_Signature                  => RE_Set_Signature,
 320        Set_SSD                        => RE_Set_SSD,
 321        Set_Tagged_Kind                => RE_Set_Tagged_Kind);
 322
 323    Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
 324       (IW_Membership                  => False,
 325        Get_Entry_Index                => False,
 326        Get_Prim_Op_Kind               => False,
 327        Get_Tagged_Kind                => False,
 328        Register_Interface_Tag         => True,
 329        Register_Tag                   => True,
 330        Set_Entry_Index                => True,
 331        Set_Offset_Index               => True,
 332        Set_OSD                        => True,
 333        Set_Prim_Op_Kind               => True,
 334        Set_Signature                  => True,
 335        Set_SSD                        => True,
 336        Set_Tagged_Kind                => True);
 337
 338    Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
 339       (IW_Membership                  => 2,
 340        Get_Entry_Index                => 2,
 341        Get_Prim_Op_Kind               => 2,
 342        Get_Tagged_Kind                => 1,
 343        Register_Interface_Tag         => 3,
 344        Register_Tag                   => 1,
 345        Set_Entry_Index                => 3,
 346        Set_Offset_Index               => 3,
 347        Set_OSD                        => 2,
 348        Set_Prim_Op_Kind               => 3,
 349        Set_Signature                  => 2,
 350        Set_SSD                        => 2,
 351        Set_Tagged_Kind                => 2);
 352
 353    function Default_Prim_Op_Position (E : Entity_Id) return Uint;
 354    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
 355    --  of the default primitive operations.
 356
 357    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
 358    --  Returns true if Prim is not a predefined dispatching primitive but it is
 359    --  an alias of a predefined dispatching primitive (ie. through a renaming)
 360
 361    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
 362    --  Check if the type has a private view or if the public view appears
 363    --  in the visible part of a package spec.
 364
 365    function Prim_Op_Kind
 366      (Prim : Entity_Id;
 367       Typ  : Entity_Id) return Node_Id;
 368    --  Ada 2005 (AI-345): Determine the primitive operation kind of Prim
 369    --  according to its type Typ. Return a reference to an RE_Prim_Op_Kind
 370    --  enumeration value.
 371
 372    function Tagged_Kind (T : Entity_Id) return Node_Id;
 373    --  Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
 374    --  to an RE_Tagged_Kind enumeration value.
 375
 376    ------------------------------
 377    -- Default_Prim_Op_Position --
 378    ------------------------------
 379
 380    function Default_Prim_Op_Position (E : Entity_Id) return Uint is
 381       TSS_Name : TSS_Name_Type;
 382
 383    begin
 384       Get_Name_String (Chars (E));
 385       TSS_Name :=
 386         TSS_Name_Type
 387           (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
 388
 389       if Chars (E) = Name_uSize then
 390          return Uint_1;
 391
 392       elsif Chars (E) = Name_uAlignment then
 393          return Uint_2;
 394
 395       elsif TSS_Name = TSS_Stream_Read then
 396          return Uint_3;
 397
 398       elsif TSS_Name = TSS_Stream_Write then
 399          return Uint_4;
 400
 401       elsif TSS_Name = TSS_Stream_Input then
 402          return Uint_5;
 403
 404       elsif TSS_Name = TSS_Stream_Output then
 405          return Uint_6;
 406
 407       elsif Chars (E) = Name_Op_Eq then
 408          return Uint_7;
 409
 410       elsif Chars (E) = Name_uAssign then
 411          return Uint_8;
 412
 413       elsif TSS_Name = TSS_Deep_Adjust then
 414          return Uint_9;
 415
 416       elsif TSS_Name = TSS_Deep_Finalize then
 417          return Uint_10;
 418
 419       elsif Ada_Version >= Ada_05 then
 420          if Chars (E) = Name_uDisp_Asynchronous_Select then
 421             return Uint_11;
 422
 423          elsif Chars (E) = Name_uDisp_Conditional_Select then
 424             return Uint_12;
 425
 426          elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
 427             return Uint_13;
 428
 429          elsif Chars (E) = Name_uDisp_Get_Task_Id then
 430             return Uint_14;
 431
 432          elsif Chars (E) = Name_uDisp_Timed_Select then
 433             return Uint_15;
 434          end if;
 435       end if;
 436
 437       raise Program_Error;
 438    end Default_Prim_Op_Position;
 439
 440    -----------------------------
 441    -- Expand_Dispatching_Call --
 442    -----------------------------
 443
 444    procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
 445       Loc      : constant Source_Ptr := Sloc (Call_Node);
 446       Call_Typ : constant Entity_Id  := Etype (Call_Node);
 447
 448       Ctrl_Arg   : constant Node_Id := Controlling_Argument (Call_Node);
 449       Param_List : constant List_Id := Parameter_Associations (Call_Node);
 450
 451       Subp            : Entity_Id;
 452       CW_Typ          : Entity_Id;
 453       New_Call        : Node_Id;
 454       New_Call_Name   : Node_Id;
 455       New_Params      : List_Id := No_List;
 456       Param           : Node_Id;
 457       Res_Typ         : Entity_Id;
 458       Subp_Ptr_Typ    : Entity_Id;
 459       Subp_Typ        : Entity_Id;
 460       Typ             : Entity_Id;
 461       Eq_Prim_Op      : Entity_Id := Empty;
 462       Controlling_Tag : Node_Id;
 463
 464       function New_Value (From : Node_Id) return Node_Id;
 465       --  From is the original Expression. New_Value is equivalent to a call
 466       --  to Duplicate_Subexpr with an explicit dereference when From is an
 467       --  access parameter.
 468
 469       ---------------
 470       -- New_Value --
 471       ---------------
 472
 473       function New_Value (From : Node_Id) return Node_Id is
 474          Res : constant Node_Id := Duplicate_Subexpr (From);
 475       begin
 476          if Is_Access_Type (Etype (From)) then
 477             return
 478               Make_Explicit_Dereference (Sloc (From),
 479                 Prefix => Res);
 480          else
 481             return Res;
 482          end if;
 483       end New_Value;
 484
 485    --  Start of processing for Expand_Dispatching_Call
 486
 487    begin
 488       --  Expand_Dispatching_Call is called directly from the semantics,
 489       --  so we need a check to see whether expansion is active before
 490       --  proceeding. In addition, there is no need to expand the call
 491       --  if we are compiling under restriction No_Dispatching_Calls;
 492       --  the semantic analyzer has previously notified the violation
 493       --  of this restriction.
 494
 495       if not Expander_Active
 496         or else Restriction_Active (No_Dispatching_Calls)
 497       then
 498          return;
 499       end if;
 500
 501       --  Set subprogram. If this is an inherited operation that was
 502       --  overridden, the body that is being called is its alias.
 503
 504       Subp := Entity (Name (Call_Node));
 505
 506       if Present (Alias (Subp))
 507         and then Is_Inherited_Operation (Subp)
 508         and then No (DTC_Entity (Subp))
 509       then
 510          Subp := Alias (Subp);
 511       end if;
 512
 513       --  Definition of the class-wide type and the tagged type
 514
 515       --  If the controlling argument is itself a tag rather than a tagged
 516       --  object, then use the class-wide type associated with the subprogram's
 517       --  controlling type. This case can occur when a call to an inherited
 518       --  primitive has an actual that originated from a default parameter
 519       --  given by a tag-indeterminate call and when there is no other
 520       --  controlling argument providing the tag (AI-239 requires dispatching).
 521       --  This capability of dispatching directly by tag is also needed by the
 522       --  implementation of AI-260 (for the generic dispatching constructors).
 523
 524       if Etype (Ctrl_Arg) = RTE (RE_Tag)
 525         or else (RTE_Available (RE_Interface_Tag)
 526                   and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
 527       then
 528          CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
 529
 530       elsif Is_Access_Type (Etype (Ctrl_Arg)) then
 531          CW_Typ := Designated_Type (Etype (Ctrl_Arg));
 532
 533       else
 534          CW_Typ := Etype (Ctrl_Arg);
 535       end if;
 536
 537       Typ := Root_Type (CW_Typ);
 538
 539       if Ekind (Typ) = E_Incomplete_Type then
 540          Typ := Non_Limited_View (Typ);
 541       end if;
 542
 543       if not Is_Limited_Type (Typ) then
 544          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
 545       end if;
 546
 547       --  Dispatching call to C++ primitive. Create a new parameter list
 548       --  with no tag checks.
 549
 550       if Is_CPP_Class (Typ) then
 551          New_Params := New_List;
 552          Param := First_Actual (Call_Node);
 553          while Present (Param) loop
 554             Append_To (New_Params, Relocate_Node (Param));
 555             Next_Actual (Param);
 556          end loop;
 557
 558       --  Dispatching call to Ada primitive
 559
 560       elsif Present (Param_List) then
 561
 562          --  Generate the Tag checks when appropriate
 563
 564          New_Params := New_List;
 565          Param := First_Actual (Call_Node);
 566          while Present (Param) loop
 567
 568             --  No tag check with itself
 569
 570             if Param = Ctrl_Arg then
 571                Append_To (New_Params,
 572                  Duplicate_Subexpr_Move_Checks (Param));
 573
 574             --  No tag check for parameter whose type is neither tagged nor
 575             --  access to tagged (for access parameters)
 576
 577             elsif No (Find_Controlling_Arg (Param)) then
 578                Append_To (New_Params, Relocate_Node (Param));
 579
 580             --  No tag check for function dispatching on result if the
 581             --  Tag given by the context is this one
 582
 583             elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
 584                Append_To (New_Params, Relocate_Node (Param));
 585
 586             --  "=" is the only dispatching operation allowed to get
 587             --  operands with incompatible tags (it just returns false).
 588             --  We use Duplicate_Subexpr_Move_Checks instead of calling
 589             --  Relocate_Node because the value will be duplicated to
 590             --  check the tags.
 591
 592             elsif Subp = Eq_Prim_Op then
 593                Append_To (New_Params,
 594                  Duplicate_Subexpr_Move_Checks (Param));
 595
 596             --  No check in presence of suppress flags
 597
 598             elsif Tag_Checks_Suppressed (Etype (Param))
 599               or else (Is_Access_Type (Etype (Param))
 600                          and then Tag_Checks_Suppressed
 601                                     (Designated_Type (Etype (Param))))
 602             then
 603                Append_To (New_Params, Relocate_Node (Param));
 604
 605             --  Optimization: no tag checks if the parameters are identical
 606
 607             elsif Is_Entity_Name (Param)
 608               and then Is_Entity_Name (Ctrl_Arg)
 609               and then Entity (Param) = Entity (Ctrl_Arg)
 610             then
 611                Append_To (New_Params, Relocate_Node (Param));
 612
 613             --  Now we need to generate the Tag check
 614
 615             else
 616                --  Generate code for tag equality check
 617                --  Perhaps should have Checks.Apply_Tag_Equality_Check???
 618
 619                Insert_Action (Ctrl_Arg,
 620                  Make_Implicit_If_Statement (Call_Node,
 621                    Condition =>
 622                      Make_Op_Ne (Loc,
 623                        Left_Opnd =>
 624                          Make_Selected_Component (Loc,
 625                            Prefix => New_Value (Ctrl_Arg),
 626                            Selector_Name =>
 627                              New_Reference_To
 628                                (First_Tag_Component (Typ), Loc)),
 629
 630                        Right_Opnd =>
 631                          Make_Selected_Component (Loc,
 632                            Prefix =>
 633                              Unchecked_Convert_To (Typ, New_Value (Param)),
 634                            Selector_Name =>
 635                              New_Reference_To
 636                                (First_Tag_Component (Typ), Loc))),
 637
 638                    Then_Statements =>
 639                      New_List (New_Constraint_Error (Loc))));
 640
 641                Append_To (New_Params, Relocate_Node (Param));
 642             end if;
 643
 644             Next_Actual (Param);
 645          end loop;
 646       end if;
 647
 648       --  Generate the appropriate subprogram pointer type
 649
 650       if Etype (Subp) = Typ then
 651          Res_Typ := CW_Typ;
 652       else
 653          Res_Typ := Etype (Subp);
 654       end if;
 655
 656       Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
 657       Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
 658       Set_Etype          (Subp_Typ, Res_Typ);
 659       Init_Size_Align    (Subp_Ptr_Typ);
 660       Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
 661
 662       --  Create a new list of parameters which is a copy of the old formal
 663       --  list including the creation of a new set of matching entities.
 664
 665       declare
 666          Old_Formal : Entity_Id := First_Formal (Subp);
 667          New_Formal : Entity_Id;
 668          Extra      : Entity_Id;
 669
 670       begin
 671          if Present (Old_Formal) then
 672             New_Formal := New_Copy (Old_Formal);
 673             Set_First_Entity (Subp_Typ, New_Formal);
 674             Param := First_Actual (Call_Node);
 675
 676             loop
 677                Set_Scope (New_Formal, Subp_Typ);
 678
 679                --  Change all the controlling argument types to be class-wide
 680                --  to avoid a recursion in dispatching.
 681
 682                if Is_Controlling_Formal (New_Formal) then
 683                   Set_Etype (New_Formal, Etype (Param));
 684                end if;
 685
 686                if Is_Itype (Etype (New_Formal)) then
 687                   Extra := New_Copy (Etype (New_Formal));
 688
 689                   if Ekind (Extra) = E_Record_Subtype
 690                     or else Ekind (Extra) = E_Class_Wide_Subtype
 691                   then
 692                      Set_Cloned_Subtype (Extra, Etype (New_Formal));
 693                   end if;
 694
 695                   Set_Etype (New_Formal, Extra);
 696                   Set_Scope (Etype (New_Formal), Subp_Typ);
 697                end if;
 698
 699                Extra := New_Formal;
 700                Next_Formal (Old_Formal);
 701                exit when No (Old_Formal);
 702
 703                Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
 704                Next_Entity (New_Formal);
 705                Next_Actual (Param);
 706             end loop;
 707
 708             Set_Next_Entity (New_Formal, Empty);
 709             Set_Last_Entity (Subp_Typ, Extra);
 710
 711             --  Copy extra formals
 712
 713             New_Formal := First_Entity (Subp_Typ);
 714             while Present (New_Formal) loop
 715                if Present (Extra_Constrained (New_Formal)) then
 716                   Set_Extra_Formal (Extra,
 717                     New_Copy (Extra_Constrained (New_Formal)));
 718                   Extra := Extra_Formal (Extra);
 719                   Set_Extra_Constrained (New_Formal, Extra);
 720
 721                elsif Present (Extra_Accessibility (New_Formal)) then
 722                   Set_Extra_Formal (Extra,
 723                     New_Copy (Extra_Accessibility (New_Formal)));
 724                   Extra := Extra_Formal (Extra);
 725                   Set_Extra_Accessibility (New_Formal, Extra);
 726                end if;
 727
 728                Next_Formal (New_Formal);
 729             end loop;
 730          end if;
 731       end;
 732
 733       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
 734       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
 735
 736       --  If the controlling argument is a value of type Ada.Tag or an abstract
 737       --  interface class-wide type then use it directly. Otherwise, the tag
 738       --  must be extracted from the controlling object.
 739
 740       if Etype (Ctrl_Arg) = RTE (RE_Tag)
 741         or else (RTE_Available (RE_Interface_Tag)
 742                   and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
 743       then
 744          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
 745
 746       --  Extract the tag from an unchecked type conversion. Done to avoid
 747       --  the expansion of additional code just to obtain the value of such
 748       --  tag because the current management of interface type conversions
 749       --  generates in some cases this unchecked type conversion with the
 750       --  tag of the object (see Expand_Interface_Conversion).
 751
 752       elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
 753         and then
 754           (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
 755             or else
 756               (RTE_Available (RE_Interface_Tag)
 757                 and then
 758                   Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
 759       then
 760          Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
 761
 762       --  Ada 2005 (AI-251): Abstract interface class-wide type
 763
 764       elsif Is_Interface (Etype (Ctrl_Arg))
 765          and then Is_Class_Wide_Type (Etype (Ctrl_Arg))
 766       then
 767          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
 768
 769       else
 770          Controlling_Tag :=
 771            Make_Selected_Component (Loc,
 772              Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
 773              Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
 774       end if;
 775
 776       --  Handle dispatching calls to predefined primitives
 777
 778       if Is_Predefined_Dispatching_Operation (Subp)
 779         or else Is_Predefined_Dispatching_Alias (Subp)
 780       then
 781          New_Call_Name :=
 782            Unchecked_Convert_To (Subp_Ptr_Typ,
 783              Build_Get_Predefined_Prim_Op_Address (Loc,
 784                Tag_Node => Controlling_Tag,
 785                Position_Node => Make_Integer_Literal (Loc,
 786                                   DT_Position (Subp))));
 787
 788       --  Handle dispatching calls to user-defined primitives
 789
 790       else
 791          New_Call_Name :=
 792            Unchecked_Convert_To (Subp_Ptr_Typ,
 793              Build_Get_Prim_Op_Address (Loc,
 794                Tag_Node      => Controlling_Tag,
 795                Position_Node => Make_Integer_Literal (Loc,
 796                                   DT_Position (Subp))));
 797       end if;
 798
 799       if Nkind (Call_Node) = N_Function_Call then
 800
 801          --  Ada 2005 (AI-251): A dispatching "=" with an abstract interface
 802          --  just requires the comparison of the tags.
 803
 804          if Ekind (Etype (Ctrl_Arg)) = E_Class_Wide_Type
 805            and then Is_Interface (Etype (Ctrl_Arg))
 806            and then Subp = Eq_Prim_Op
 807          then
 808             Param := First_Actual (Call_Node);
 809
 810             New_Call :=
 811                 Make_Op_Eq (Loc,
 812                    Left_Opnd =>
 813                      Make_Selected_Component (Loc,
 814                        Prefix => New_Value (Param),
 815                        Selector_Name =>
 816                          New_Reference_To (First_Tag_Component (Typ), Loc)),
 817
 818                    Right_Opnd =>
 819                      Make_Selected_Component (Loc,
 820                        Prefix =>
 821                          Unchecked_Convert_To (Typ,
 822                            New_Value (Next_Actual (Param))),
 823                        Selector_Name =>
 824                          New_Reference_To (First_Tag_Component (Typ), Loc)));
 825
 826          else
 827             New_Call :=
 828               Make_Function_Call (Loc,
 829                 Name => New_Call_Name,
 830                 Parameter_Associations => New_Params);
 831
 832             --  If this is a dispatching "=", we must first compare the tags so
 833             --  we generate: x.tag = y.tag and then x = y
 834
 835             if Subp = Eq_Prim_Op then
 836                Param := First_Actual (Call_Node);
 837                New_Call :=
 838                  Make_And_Then (Loc,
 839                    Left_Opnd =>
 840                         Make_Op_Eq (Loc,
 841                           Left_Opnd =>
 842                             Make_Selected_Component (Loc,
 843                               Prefix => New_Value (Param),
 844                               Selector_Name =>
 845                                 New_Reference_To (First_Tag_Component (Typ),
 846                                                   Loc)),
 847
 848                           Right_Opnd =>
 849                             Make_Selected_Component (Loc,
 850                               Prefix =>
 851                                 Unchecked_Convert_To (Typ,
 852                                   New_Value (Next_Actual (Param))),
 853                               Selector_Name =>
 854                                 New_Reference_To (First_Tag_Component (Typ),
 855                                                   Loc))),
 856                    Right_Opnd => New_Call);
 857             end if;
 858          end if;
 859
 860       else
 861          New_Call :=
 862            Make_Procedure_Call_Statement (Loc,
 863              Name => New_Call_Name,
 864              Parameter_Associations => New_Params);
 865       end if;
 866
 867       Rewrite (Call_Node, New_Call);
 868       Analyze_And_Resolve (Call_Node, Call_Typ);
 869    end Expand_Dispatching_Call;
 870
 871    ---------------------------------
 872    -- Expand_Interface_Conversion --
 873    ---------------------------------
 874
 875    procedure Expand_Interface_Conversion
 876      (N         : Node_Id;
 877       Is_Static : Boolean := True)
 878    is
 879       Loc         : constant Source_Ptr := Sloc (N);
 880       Etyp        : constant Entity_Id  := Etype (N);
 881       Operand     : constant Node_Id    := Expression (N);
 882       Operand_Typ : Entity_Id           := Etype (Operand);
 883       Fent        : Entity_Id;
 884       Func        : Node_Id;
 885       Iface_Typ   : Entity_Id           := Etype (N);
 886       Iface_Tag   : Entity_Id;
 887       New_Itype   : Entity_Id;
 888
 889    begin
 890       pragma Assert (Nkind (Operand) /= N_Attribute_Reference);
 891
 892       --  Ada 2005 (AI-345): Handle synchronized interface type derivations
 893
 894       if Is_Concurrent_Type (Operand_Typ) then
 895          Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
 896       end if;
 897
 898       --  Handle access types to interfaces
 899
 900       if Is_Access_Type (Iface_Typ) then
 901          Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
 902       end if;
 903
 904       --  Handle class-wide interface types. This conversion can appear
 905       --  explicitly in the source code. Example: I'Class (Obj)
 906
 907       if Is_Class_Wide_Type (Iface_Typ) then
 908          Iface_Typ := Etype (Iface_Typ);
 909       end if;
 910
 911       pragma Assert (not Is_Static
 912         or else (not Is_Class_Wide_Type (Iface_Typ)
 913                   and then Is_Interface (Iface_Typ)));
 914
 915       if not Is_Static then
 916
 917          --  Give error if configurable run time and Displace not available
 918
 919          if not RTE_Available (RE_Displace) then
 920             Error_Msg_CRT ("abstract interface types", N);
 921             return;
 922          end if;
 923
 924          --  Handle conversion of access to class-wide interface types. The
 925          --  target can be an access to object or an access to another class
 926          --  wide interfac (see -1- and -2- in the following example):
 927
 928          --     type Iface1_Ref is access all Iface1'Class;
 929          --     type Iface2_Ref is access all Iface1'Class;
 930
 931          --     Acc1 : Iface1_Ref := new ...
 932          --     Obj  : Obj_Ref    := Obj_Ref (Acc);    -- 1
 933          --     Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
 934
 935          if Is_Access_Type (Operand_Typ) then
 936             pragma Assert
 937               (Is_Class_Wide_Type (Directly_Designated_Type (Operand_Typ))
 938                  and then
 939                Is_Interface (Directly_Designated_Type (Operand_Typ)));
 940
 941             Rewrite (N,
 942               Unchecked_Convert_To (Etype (N),
 943                 Make_Function_Call (Loc,
 944                   Name => New_Reference_To (RTE (RE_Displace), Loc),
 945                   Parameter_Associations => New_List (
 946
 947                     Unchecked_Convert_To (RTE (RE_Address),
 948                       Relocate_Node (Expression (N))),
 949
 950                     New_Occurrence_Of
 951                       (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
 952                        Loc)))));
 953
 954             Analyze (N);
 955             return;
 956          end if;
 957
 958          Rewrite (N,
 959            Make_Function_Call (Loc,
 960              Name => New_Reference_To (RTE (RE_Displace), Loc),
 961              Parameter_Associations => New_List (
 962                Make_Attribute_Reference (Loc,
 963                  Prefix => Relocate_Node (Expression (N)),
 964                  Attribute_Name => Name_Address),
 965
 966                New_Occurrence_Of
 967                  (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
 968                   Loc))));
 969
 970          Analyze (N);
 971
 972          --  If the target is a class-wide interface we change the type of the
 973          --  data returned by IW_Convert to indicate that this is a dispatching
 974          --  call.
 975
 976          New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
 977          Set_Etype       (New_Itype, New_Itype);
 978          Init_Esize      (New_Itype);
 979          Init_Size_Align (New_Itype);
 980          Set_Directly_Designated_Type (New_Itype, Etyp);
 981
 982          Rewrite (N, Make_Explicit_Dereference (Loc,
 983                           Unchecked_Convert_To (New_Itype,
 984                             Relocate_Node (N))));
 985          Analyze (N);
 986          Freeze_Itype (New_Itype, N);
 987
 988          return;
 989       end if;
 990
 991       Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
 992       pragma Assert (Iface_Tag /= Empty);
 993
 994       --  Keep separate access types to interfaces because one internal
 995       --  function is used to handle the null value (see following comment)
 996
 997       if not Is_Access_Type (Etype (N)) then
 998          Rewrite (N,
 999            Unchecked_Convert_To (Etype (N),
1000              Make_Selected_Component (Loc,
1001                Prefix => Relocate_Node (Expression (N)),
1002                Selector_Name =>
1003                  New_Occurrence_Of (Iface_Tag, Loc))));
1004
1005       else
1006          --  Build internal function to handle the case in which the
1007          --  actual is null. If the actual is null returns null because
1008          --  no displacement is required; otherwise performs a type
1009          --  conversion that will be expanded in the code that returns
1010          --  the value of the displaced actual. That is:
1011
1012          --     function Func (O : Address) return Iface_Typ is
1013          --     begin
1014          --        if O = Null_Address then
1015          --           return null;
1016          --        else
1017          --           return Iface_Typ!(Operand_Typ!(O).Iface_Tag'Address);
1018          --        end if;
1019          --     end Func;
1020
1021          Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
1022          Set_Is_Internal (Fent);
1023
1024          declare
1025             Desig_Typ : Entity_Id;
1026          begin
1027             Desig_Typ := Etype (Expression (N));
1028
1029             if Is_Access_Type (Desig_Typ) then
1030                Desig_Typ := Directly_Designated_Type (Desig_Typ);
1031             end if;
1032
1033             New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1034             Set_Etype       (New_Itype, New_Itype);
1035             Set_Scope       (New_Itype, Fent);
1036             Init_Size_Align (New_Itype);
1037             Set_Directly_Designated_Type (New_Itype, Desig_Typ);
1038          end;
1039
1040          Func :=
1041            Make_Subprogram_Body (Loc,
1042              Specification =>
1043                Make_Function_Specification (Loc,
1044                  Defining_Unit_Name       => Fent,
1045
1046                  Parameter_Specifications => New_List (
1047                    Make_Parameter_Specification (Loc,
1048                      Defining_Identifier =>
1049                        Make_Defining_Identifier (Loc, Name_uO),
1050                      Parameter_Type =>
1051                        New_Reference_To (RTE (RE_Address), Loc))),
1052
1053                  Result_Definition =>
1054                    New_Reference_To (Etype (N), Loc)),
1055
1056              Declarations => Empty_List,
1057
1058              Handled_Statement_Sequence =>
1059                Make_Handled_Sequence_Of_Statements (Loc,
1060                  Statements => New_List (
1061                    Make_If_Statement (Loc,
1062                      Condition       =>
1063                        Make_Op_Eq (Loc,
1064                           Left_Opnd  => Make_Identifier (Loc, Name_uO),
1065                           Right_Opnd => New_Reference_To
1066                                           (RTE (RE_Null_Address), Loc)),
1067
1068                      Then_Statements => New_List (
1069                        Make_Return_Statement (Loc,
1070                          Make_Null (Loc))),
1071
1072                      Else_Statements => New_List (
1073                        Make_Return_Statement (Loc,
1074                          Unchecked_Convert_To (Etype (N),
1075                            Make_Attribute_Reference (Loc,
1076                              Prefix =>
1077                                Make_Selected_Component (Loc,
1078                                  Prefix => Unchecked_Convert_To (New_Itype,
1079                                              Make_Identifier (Loc, Name_uO)),
1080                                  Selector_Name =>
1081                                    New_Occurrence_Of (Iface_Tag, Loc)),
1082                              Attribute_Name => Name_Address))))))));
1083
1084          --  Place function body before the expression containing
1085          --  the conversion
1086
1087          Insert_Action (N, Func);
1088          Analyze (Func);
1089
1090          if Is_Access_Type (Etype (Expression (N))) then
1091
1092             --  Generate: Operand_Typ!(Expression.all)'Address
1093
1094             Rewrite (N,
1095               Make_Function_Call (Loc,
1096                 Name => New_Reference_To (Fent, Loc),
1097                 Parameter_Associations => New_List (
1098                   Make_Attribute_Reference (Loc,
1099                     Prefix  => Unchecked_Convert_To (Operand_Typ,
1100                                  Make_Explicit_Dereference (Loc,
1101                                    Relocate_Node (Expression (N)))),
1102                     Attribute_Name => Name_Address))));
1103
1104          else
1105             --  Generate: Operand_Typ!(Expression)'Address
1106
1107             Rewrite (N,
1108               Make_Function_Call (Loc,
1109                 Name => New_Reference_To (Fent, Loc),
1110                 Parameter_Associations => New_List (
1111                   Make_Attribute_Reference (Loc,
1112                     Prefix  => Unchecked_Convert_To (Operand_Typ,
1113                                  Relocate_Node (Expression (N))),
1114                     Attribute_Name => Name_Address))));
1115          end if;
1116       end if;
1117
1118       Analyze (N);
1119    end Expand_Interface_Conversion;
1120
1121    ------------------------------
1122    -- Expand_Interface_Actuals --
1123    ------------------------------
1124
1125    procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1126       Loc        : constant Source_Ptr := Sloc (Call_Node);
1127       Actual     : Node_Id;
1128       Actual_Dup : Node_Id;
1129       Actual_Typ : Entity_Id;
1130       Anon       : Entity_Id;
1131       Conversion : Node_Id;
1132       Formal     : Entity_Id;
1133       Formal_Typ : Entity_Id;
1134       Subp       : Entity_Id;
1135       Nam        : Name_Id;
1136       Formal_DDT : Entity_Id;
1137       Actual_DDT : Entity_Id;
1138
1139    begin
1140       --  This subprogram is called directly from the semantics, so we need a
1141       --  check to see whether expansion is active before proceeding.
1142
1143       if not Expander_Active then
1144          return;
1145       end if;
1146
1147       --  Call using access to subprogram with explicit dereference
1148
1149       if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1150          Subp := Etype (Name (Call_Node));
1151
1152       --  Normal case
1153
1154       else
1155          Subp := Entity (Name (Call_Node));
1156       end if;
1157
1158       Formal := First_Formal (Subp);
1159       Actual := First_Actual (Call_Node);
1160       while Present (Formal) loop
1161
1162          --  Ada 2005 (AI-251): Conversion to interface to force "this"
1163          --  displacement.
1164
1165          Formal_Typ := Etype (Etype (Formal));
1166
1167          if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1168             Formal_Typ := Full_View (Formal_Typ);
1169          end if;
1170
1171          if Is_Access_Type (Formal_Typ) then
1172             Formal_DDT := Directly_Designated_Type (Formal_Typ);
1173          end if;
1174
1175          Actual_Typ := Etype (Actual);
1176
1177          if Is_Access_Type (Actual_Typ) then
1178             Actual_DDT := Directly_Designated_Type (Actual_Typ);
1179          end if;
1180
1181          if Is_Interface (Formal_Typ) then
1182
1183             --  No need to displace the pointer if the type of the actual
1184             --  is class-wide of the formal-type interface; in this case the
1185             --  displacement of the pointer was already done at the point of
1186             --  the call to the enclosing subprogram. This case corresponds
1187             --  with the call to P (Obj) in the following example:
1188
1189             --     type I is interface;
1190             --     procedure P (X : I) is abstract;
1191
1192             --     procedure General_Op (Obj : I'Class) is
1193             --     begin
1194             --        P (Obj);
1195             --     end General_Op;
1196
1197             if Is_Class_Wide_Type (Actual_Typ)
1198               and then Etype (Actual_Typ) = Formal_Typ
1199             then
1200                null;
1201
1202             --  No need to displace the pointer if the type of the actual is a
1203             --  derivation of the formal-type interface because in this case
1204             --  the interface primitives are located in the primary dispatch
1205             --  table.
1206
1207             elsif Is_Parent (Formal_Typ, Actual_Typ) then
1208                null;
1209
1210             else
1211                Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1212                Rewrite             (Actual, Conversion);
1213                Analyze_And_Resolve (Actual, Formal_Typ);
1214             end if;
1215
1216          --  Anonymous access type
1217
1218          elsif Is_Access_Type (Formal_Typ)
1219            and then Is_Interface (Etype (Formal_DDT))
1220            and then Interface_Present_In_Ancestor
1221                       (Typ   => Actual_DDT,
1222                        Iface => Etype (Formal_DDT))
1223          then
1224             if Nkind (Actual) = N_Attribute_Reference
1225               and then
1226                (Attribute_Name (Actual) = Name_Access
1227                  or else Attribute_Name (Actual) = Name_Unchecked_Access)
1228             then
1229                Nam := Attribute_Name (Actual);
1230
1231                Conversion := Convert_To (Etype (Formal_DDT), Prefix (Actual));
1232
1233                Rewrite (Actual, Conversion);
1234                Analyze_And_Resolve (Actual, Etype (Formal_DDT));
1235
1236                Rewrite (Actual,
1237                  Unchecked_Convert_To (Formal_Typ,
1238                    Make_Attribute_Reference (Loc,
1239                      Prefix => Relocate_Node (Actual),
1240                      Attribute_Name => Nam)));
1241
1242                Analyze_And_Resolve (Actual, Formal_Typ);
1243
1244             --  No need to displace the pointer if the actual is a class-wide
1245             --  type of the formal-type interface because in this case the
1246             --  displacement of the pointer was already done at the point of
1247             --  the call to the enclosing subprogram (this case is similar
1248             --  to the example described above for the non access-type case)
1249
1250             elsif Is_Class_Wide_Type (Actual_DDT)
1251               and then Etype (Actual_DDT) = Formal_DDT
1252             then
1253                null;
1254
1255             --  No need to displace the pointer if the type of the actual is a
1256             --  derivation of the interface (because in this case the interface
1257             --  primitives are located in the primary dispatch table)
1258
1259             elsif Is_Parent (Formal_DDT, Actual_DDT) then
1260                null;
1261
1262             else
1263                Actual_Dup := Relocate_Node (Actual);
1264
1265                if From_With_Type (Actual_Typ) then
1266
1267                   --  If the type of the actual parameter comes from a limited
1268                   --  with-clause and the non-limited view is already available
1269                   --  we replace the anonymous access type by a duplicate decla
1270                   --  ration whose designated type is the non-limited view
1271
1272                   if Ekind (Actual_DDT) = E_Incomplete_Type
1273                     and then Present (Non_Limited_View (Actual_DDT))
1274                   then
1275                      Anon := New_Copy (Actual_Typ);
1276
1277                      if Is_Itype (Anon) then
1278                         Set_Scope (Anon, Current_Scope);
1279                      end if;
1280
1281                      Set_Directly_Designated_Type (Anon,
1282                        Non_Limited_View (Actual_DDT));
1283                      Set_Etype (Actual_Dup, Anon);
1284
1285                   elsif Is_Class_Wide_Type (Actual_DDT)
1286                     and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
1287                     and then Present (Non_Limited_View (Etype (Actual_DDT)))
1288                   then
1289                      Anon := New_Copy (Actual_Typ);
1290
1291                      if Is_Itype (Anon) then
1292                         Set_Scope (Anon, Current_Scope);
1293                      end if;
1294
1295                      Set_Directly_Designated_Type (Anon,
1296                        New_Copy (Actual_DDT));
1297                      Set_Class_Wide_Type (Directly_Designated_Type (Anon),
1298                        New_Copy (Class_Wide_Type (Actual_DDT)));
1299                      Set_Etype (Directly_Designated_Type (Anon),
1300                        Non_Limited_View (Etype (Actual_DDT)));
1301                      Set_Etype (
1302                        Class_Wide_Type (Directly_Designated_Type (Anon)),
1303                        Non_Limited_View (Etype (Actual_DDT)));
1304                      Set_Etype (Actual_Dup, Anon);
1305                   end if;
1306                end if;
1307
1308                Conversion := Convert_To (Formal_Typ, Actual_Dup);
1309                Rewrite (Actual, Conversion);
1310                Analyze_And_Resolve (Actual, Formal_Typ);
1311             end if;
1312          end if;
1313
1314          Next_Actual (Actual);
1315          Next_Formal (Formal);
1316       end loop;
1317    end Expand_Interface_Actuals;
1318
1319    ----------------------------
1320    -- Expand_Interface_Thunk --
1321    ----------------------------
1322
1323    function Expand_Interface_Thunk
1324      (N           : Node_Id;
1325       Thunk_Alias : Entity_Id;
1326       Thunk_Id    : Entity_Id) return Node_Id
1327    is
1328       Loc         : constant Source_Ptr := Sloc (N);
1329       Actuals     : constant List_Id    := New_List;
1330       Decl        : constant List_Id    := New_List;
1331       Formals     : constant List_Id    := New_List;
1332       Target      : Entity_Id;
1333       New_Code    : Node_Id;
1334       Formal      : Node_Id;
1335       New_Formal  : Node_Id;
1336       Decl_1      : Node_Id;
1337       Decl_2      : Node_Id;
1338       E           : Entity_Id;
1339
1340    begin
1341       --  Traverse the list of alias to find the final target
1342
1343       Target := Thunk_Alias;
1344       while Present (Alias (Target)) loop
1345          Target := Alias (Target);
1346       end loop;
1347
1348       --  Duplicate the formals
1349
1350       Formal := First_Formal (Target);
1351       E      := First_Formal (N);
1352       while Present (Formal) loop
1353          New_Formal := Copy_Separate_Tree (Parent (Formal));
1354
1355          --  Propagate the parameter type to the copy. This is required to
1356          --  properly handle the case in which the subprogram covering the
1357          --  interface has been inherited:
1358
1359          --  Example:
1360          --     type I is interface;
1361          --     procedure P (X : I) is abstract;
1362
1363          --     type T is tagged null record;
1364          --     procedure P (X : T);
1365
1366          --     type DT is new T and I with ...
1367
1368          Set_Parameter_Type (New_Formal, New_Reference_To (Etype (E), Loc));
1369          Append_To (Formals, New_Formal);
1370
1371          Next_Formal (Formal);
1372          Next_Formal (E);
1373       end loop;
1374
1375       --  Give message if configurable run-time and Offset_To_Top unavailable
1376
1377       if not RTE_Available (RE_Offset_To_Top) then
1378          Error_Msg_CRT ("abstract interface types", N);
1379          return Empty;
1380       end if;
1381
1382       if Ekind (First_Formal (Target)) = E_In_Parameter
1383         and then Ekind (Etype (First_Formal (Target)))
1384                   = E_Anonymous_Access_Type
1385       then
1386          --  Generate:
1387
1388          --     type T is access all <<type of the first formal>>
1389          --     S1 := Storage_Offset!(First_formal)
1390          --           - Offset_To_Top (First_Formal.Tag)
1391
1392          --  ... and the first actual of the call is generated as T!(S1)
1393
1394          Decl_2 :=
1395            Make_Full_Type_Declaration (Loc,
1396              Defining_Identifier =>
1397                Make_Defining_Identifier (Loc,
1398                  New_Internal_Name ('T')),
1399              Type_Definition =>
1400                Make_Access_To_Object_Definition (Loc,
1401                  All_Present            => True,
1402                  Null_Exclusion_Present => False,
1403                  Constant_Present       => False,
1404                  Subtype_Indication     =>
1405                    New_Reference_To
1406                      (Directly_Designated_Type
1407                         (Etype (First_Formal (Target))), Loc)));
1408
1409          Decl_1 :=
1410            Make_Object_Declaration (Loc,
1411              Defining_Identifier =>
1412                Make_Defining_Identifier (Loc,
1413                  New_Internal_Name ('S')),
1414              Constant_Present    => True,
1415              Object_Definition   =>
1416                New_Reference_To (RTE (RE_Storage_Offset), Loc),
1417              Expression          =>
1418                Make_Op_Subtract (Loc,
1419                  Left_Opnd  =>
1420                    Unchecked_Convert_To
1421                      (RTE (RE_Storage_Offset),
1422                       New_Reference_To
1423                         (Defining_Identifier (First (Formals)), Loc)),
1424                   Right_Opnd =>
1425                     Make_Function_Call (Loc,
1426                       Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1427                       Parameter_Associations => New_List (
1428                         Unchecked_Convert_To
1429                           (RTE (RE_Address),
1430                            New_Reference_To
1431                              (Defining_Identifier (First (Formals)), Loc))))));
1432
1433          Append_To (Decl, Decl_2);
1434          Append_To (Decl, Decl_1);
1435
1436          --  Reference the new first actual
1437
1438          Append_To (Actuals,
1439            Unchecked_Convert_To
1440              (Defining_Identifier (Decl_2),
1441               New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1442
1443       else
1444          --  Generate:
1445
1446          --     S1 := Storage_Offset!(First_formal'Address)
1447          --           - Offset_To_Top (First_Formal.Tag)
1448          --     S2 := Tag_Ptr!(S3)
1449
1450          Decl_1 :=
1451            Make_Object_Declaration (Loc,
1452              Defining_Identifier =>
1453                Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1454              Constant_Present    => True,
1455              Object_Definition   =>
1456                New_Reference_To (RTE (RE_Storage_Offset), Loc),
1457              Expression          =>
1458                Make_Op_Subtract (Loc,
1459                  Left_Opnd =>
1460                    Unchecked_Convert_To
1461                      (RTE (RE_Storage_Offset),
1462                       Make_Attribute_Reference (Loc,
1463                         Prefix =>
1464                           New_Reference_To
1465                             (Defining_Identifier (First (Formals)), Loc),
1466                         Attribute_Name => Name_Address)),
1467                  Right_Opnd =>
1468                     Make_Function_Call (Loc,
1469                       Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1470                       Parameter_Associations => New_List (
1471                         Make_Attribute_Reference (Loc,
1472                           Prefix => New_Reference_To
1473                                       (Defining_Identifier (First (Formals)),
1474                                        Loc),
1475                           Attribute_Name => Name_Address)))));
1476
1477          Decl_2 :=
1478            Make_Object_Declaration (Loc,
1479              Defining_Identifier =>
1480                Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1481              Constant_Present    => True,
1482              Object_Definition   => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1483              Expression          =>
1484                Unchecked_Convert_To
1485                  (RTE (RE_Addr_Ptr),
1486                   New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1487
1488          Append_To (Decl, Decl_1);
1489          Append_To (Decl, Decl_2);
1490
1491          --  Reference the new first actual
1492
1493          Append_To (Actuals,
1494            Unchecked_Convert_To
1495              (Etype (First_Entity (Target)),
1496               Make_Explicit_Dereference (Loc,
1497                 New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1498       end if;
1499
1500       Formal := Next (First (Formals));
1501       while Present (Formal) loop
1502          Append_To (Actuals,
1503             New_Reference_To (Defining_Identifier (Formal), Loc));
1504          Next (Formal);
1505       end loop;
1506
1507       if Ekind (Target) = E_Procedure then
1508          New_Code :=
1509            Make_Subprogram_Body (Loc,
1510               Specification =>
1511                 Make_Procedure_Specification (Loc,
1512                   Defining_Unit_Name       => Thunk_Id,
1513                   Parameter_Specifications => Formals),
1514               Declarations => Decl,
1515               Handled_Statement_Sequence =>
1516                 Make_Handled_Sequence_Of_Statements (Loc,
1517                   Statements => New_List (
1518                     Make_Procedure_Call_Statement (Loc,
1519                        Name => New_Occurrence_Of (Target, Loc),
1520                        Parameter_Associations => Actuals))));
1521
1522       else pragma Assert (Ekind (Target) = E_Function);
1523
1524          New_Code :=
1525            Make_Subprogram_Body (Loc,
1526               Specification =>
1527                 Make_Function_Specification (Loc,
1528                   Defining_Unit_Name       => Thunk_Id,
1529                   Parameter_Specifications => Formals,
1530                   Result_Definition =>
1531                     New_Copy (Result_Definition (Parent (Target)))),
1532               Declarations => Decl,
1533               Handled_Statement_Sequence =>
1534                 Make_Handled_Sequence_Of_Statements (Loc,
1535                   Statements => New_List (
1536                     Make_Return_Statement (Loc,
1537                       Make_Function_Call (Loc,
1538                         Name => New_Occurrence_Of (Target, Loc),
1539                         Parameter_Associations => Actuals)))));
1540       end if;
1541
1542       --  Analyze the code of the thunk with checks suppressed because we are
1543       --  in the middle of building the dispatch information itself and some
1544       --  characteristics of the type may not be fully available.
1545
1546       Analyze (New_Code, Suppress => All_Checks);
1547       return New_Code;
1548    end Expand_Interface_Thunk;
1549
1550    -------------------
1551    -- Fill_DT_Entry --
1552    -------------------
1553
1554    function Fill_DT_Entry
1555      (Loc     : Source_Ptr;
1556       Prim    : Entity_Id) return Node_Id
1557    is
1558       Typ     : constant Entity_Id := Scope (DTC_Entity (Prim));
1559       DT_Ptr  : constant Entity_Id :=
1560                   Node (First_Elmt (Access_Disp_Table (Typ)));
1561       Pos     : constant Uint      := DT_Position (Prim);
1562       Tag     : constant Entity_Id := First_Tag_Component (Typ);
1563
1564    begin
1565       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1566
1567       if Is_Predefined_Dispatching_Operation (Prim)
1568         or else Is_Predefined_Dispatching_Alias (Prim)
1569       then
1570          return
1571            Build_Set_Predefined_Prim_Op_Address (Loc,
1572              Tag_Node      => New_Reference_To (DT_Ptr, Loc),
1573              Position_Node => Make_Integer_Literal (Loc, Pos),
1574              Address_Node  => Make_Attribute_Reference (Loc,
1575                                 Prefix => New_Reference_To (Prim, Loc),
1576                                 Attribute_Name => Name_Address));
1577
1578       else
1579          pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
1580
1581          return
1582            Build_Set_Prim_Op_Address (Loc,
1583              Tag_Node      => New_Reference_To (DT_Ptr, Loc),
1584              Position_Node => Make_Integer_Literal (Loc, Pos),
1585              Address_Node  => Make_Attribute_Reference (Loc,
1586                                 Prefix => New_Reference_To (Prim, Loc),
1587                                 Attribute_Name => Name_Address));
1588       end if;
1589    end Fill_DT_Entry;
1590
1591    -----------------------------
1592    -- Fill_Secondary_DT_Entry --
1593    -----------------------------
1594
1595    function Fill_Secondary_DT_Entry
1596      (Loc          : Source_Ptr;
1597       Prim         : Entity_Id;
1598       Thunk_Id     : Entity_Id;
1599       Iface_DT_Ptr : Entity_Id) return Node_Id
1600    is
1601       Iface_Prim : constant Entity_Id := Abstract_Interface_Alias (Prim);
1602       Pos        : constant Uint      := DT_Position (Iface_Prim);
1603       Tag        : constant Entity_Id :=
1604                      First_Tag_Component (Scope (DTC_Entity (Iface_Prim)));
1605
1606    begin
1607       if Is_Predefined_Dispatching_Operation (Prim)
1608         or else Is_Predefined_Dispatching_Alias (Prim)
1609       then
1610          return
1611            Build_Set_Predefined_Prim_Op_Address (Loc,
1612              Tag_Node =>
1613                New_Reference_To (Iface_DT_Ptr, Loc),
1614              Position_Node =>
1615                Make_Integer_Literal (Loc, Pos),
1616              Address_Node =>
1617                Make_Attribute_Reference (Loc,
1618                  Prefix          => New_Reference_To (Thunk_Id, Loc),
1619                  Attribute_Name  => Name_Address));
1620       else
1621          pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
1622
1623          return
1624            Build_Set_Prim_Op_Address (Loc,
1625              Tag_Node      => New_Reference_To (Iface_DT_Ptr, Loc),
1626              Position_Node => Make_Integer_Literal (Loc, Pos),
1627              Address_Node  => Make_Attribute_Reference (Loc,
1628                                 Prefix => New_Reference_To (Thunk_Id, Loc),
1629                                 Attribute_Name => Name_Address));
1630       end if;
1631    end Fill_Secondary_DT_Entry;
1632
1633    -------------------------------------
1634    -- Is_Predefined_Dispatching_Alias --
1635    -------------------------------------
1636
1637    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
1638    is
1639       E : Entity_Id;
1640
1641    begin
1642       if not Is_Predefined_Dispatching_Operation (Prim)
1643         and then Present (Alias (Prim))
1644       then
1645          E := Prim;
1646          while Present (Alias (E)) loop
1647             E := Alias (E);
1648          end loop;
1649
1650          if Is_Predefined_Dispatching_Operation (E) then
1651             return True;
1652          end if;
1653       end if;
1654
1655       return False;
1656    end Is_Predefined_Dispatching_Alias;
1657
1658    ----------------------------------------
1659    -- Make_Disp_Asynchronous_Select_Body --
1660    ----------------------------------------
1661
1662    function Make_Disp_Asynchronous_Select_Body
1663      (Typ : Entity_Id) return Node_Id
1664    is
1665       Conc_Typ : Entity_Id           := Empty;
1666       Decls    : constant List_Id    := New_List;
1667       DT_Ptr   : Entity_Id;
1668       Loc      : constant Source_Ptr := Sloc (Typ);
1669       Stmts    : constant List_Id    := New_List;
1670
1671    begin
1672       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1673
1674       --  Null body is generated for interface types
1675
1676       if Is_Interface (Typ) then
1677          return
1678            Make_Subprogram_Body (Loc,
1679              Specification =>
1680                Make_Disp_Asynchronous_Select_Spec (Typ),
1681              Declarations =>
1682                New_List,
1683              Handled_Statement_Sequence =>
1684                Make_Handled_Sequence_Of_Statements (Loc,
1685                  New_List (Make_Null_Statement (Loc))));
1686       end if;
1687
1688       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1689
1690       if Is_Concurrent_Record_Type (Typ) then
1691          Conc_Typ := Corresponding_Concurrent_Type (Typ);
1692
1693          --  Generate:
1694          --    I : Integer := Get_Entry_Index (tag! (<type>VP), S);
1695
1696          --  where I will be used to capture the entry index of the primitive
1697          --  wrapper at position S.
1698
1699          Append_To (Decls,
1700            Make_Object_Declaration (Loc,
1701              Defining_Identifier =>
1702                Make_Defining_Identifier (Loc, Name_uI),
1703              Object_Definition =>
1704                New_Reference_To (Standard_Integer, Loc),
1705              Expression =>
1706                Make_DT_Access_Action (Typ,
1707                  Action =>
1708                    Get_Entry_Index,
1709                  Args =>
1710                    New_List (
1711                      Unchecked_Convert_To (RTE (RE_Tag),
1712                        New_Reference_To (DT_Ptr, Loc)),
1713                      Make_Identifier (Loc, Name_uS)))));
1714
1715          if Ekind (Conc_Typ) = E_Protected_Type then
1716
1717             --  Generate:
1718             --    Protected_Entry_Call (
1719             --      T._object'access,
1720             --      protected_entry_index! (I),
1721             --      P,
1722             --      Asynchronous_Call,
1723             --      B);
1724
1725             --  where T is the protected object, I is the entry index, P are
1726             --  the wrapped parameters and B is the name of the communication
1727             --  block.
1728
1729             Append_To (Stmts,
1730               Make_Procedure_Call_Statement (Loc,
1731                 Name =>
1732                   New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
1733                 Parameter_Associations =>
1734                   New_List (
1735
1736                     Make_Attribute_Reference (Loc,        -- T._object'access
1737                       Attribute_Name =>
1738                         Name_Unchecked_Access,
1739                       Prefix =>
1740                         Make_Selected_Component (Loc,
1741                           Prefix =>
1742                             Make_Identifier (Loc, Name_uT),
1743                           Selector_Name =>
1744                             Make_Identifier (Loc, Name_uObject))),
1745
1746                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
1747                       Subtype_Mark =>
1748                         New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
1749                       Expression =>
1750                         Make_Identifier (Loc, Name_uI)),
1751
1752                     Make_Identifier (Loc, Name_uP),       --  parameter block
1753                     New_Reference_To (                    --  Asynchronous_Call
1754                       RTE (RE_Asynchronous_Call), Loc),
1755                     Make_Identifier (Loc, Name_uB))));    --  comm block
1756          else
1757             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
1758
1759             --  Generate:
1760             --    Protected_Entry_Call (
1761             --      T._task_id,
1762             --      task_entry_index! (I),
1763             --      P,
1764             --      Conditional_Call,
1765             --      F);
1766
1767             --  where T is the task object, I is the entry index, P are the
1768             --  wrapped parameters and F is the status flag.
1769
1770             Append_To (Stmts,
1771               Make_Procedure_Call_Statement (Loc,
1772                 Name =>
1773                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
1774                 Parameter_Associations =>
1775                   New_List (
1776
1777                     Make_Selected_Component (Loc,         -- T._task_id
1778                       Prefix =>
1779                         Make_Identifier (Loc, Name_uT),
1780                       Selector_Name =>
1781                         Make_Identifier (Loc, Name_uTask_Id)),
1782
1783                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
1784                       Subtype_Mark =>
1785                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
1786                       Expression =>
1787                         Make_Identifier (Loc, Name_uI)),
1788
1789                     Make_Identifier (Loc, Name_uP),       --  parameter block
1790                     New_Reference_To (                    --  Asynchronous_Call
1791                       RTE (RE_Asynchronous_Call), Loc),
1792                     Make_Identifier (Loc, Name_uF))));    --  status flag
1793          end if;
1794       end if;
1795
1796       return
1797         Make_Subprogram_Body (Loc,
1798           Specification =>
1799             Make_Disp_Asynchronous_Select_Spec (Typ),
1800           Declarations =>
1801             Decls,
1802           Handled_Statement_Sequence =>
1803             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
1804    end Make_Disp_Asynchronous_Select_Body;
1805
1806    ----------------------------------------
1807    -- Make_Disp_Asynchronous_Select_Spec --
1808    ----------------------------------------
1809
1810    function Make_Disp_Asynchronous_Select_Spec
1811      (Typ : Entity_Id) return Node_Id
1812    is
1813       Loc    : constant Source_Ptr := Sloc (Typ);
1814       Def_Id : constant Node_Id    :=
1815                  Make_Defining_Identifier (Loc,
1816                    Name_uDisp_Asynchronous_Select);
1817       Params : constant List_Id    := New_List;
1818
1819    begin
1820       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1821
1822       --  "T" - Object parameter
1823       --  "S" - Primitive operation slot
1824       --  "P" - Wrapped parameters
1825       --  "B" - Communication block
1826       --  "F" - Status flag
1827
1828       SEU.Build_T (Loc, Typ, Params);
1829       SEU.Build_S (Loc, Params);
1830       SEU.Build_P (Loc, Params);
1831       SEU.Build_B (Loc, Params);
1832       SEU.Build_F (Loc, Params);
1833
1834       Set_Is_Internal (Def_Id);
1835
1836       return
1837          Make_Procedure_Specification (Loc,
1838            Defining_Unit_Name       => Def_Id,
1839            Parameter_Specifications => Params);
1840    end Make_Disp_Asynchronous_Select_Spec;
1841
1842    ---------------------------------------
1843    -- Make_Disp_Conditional_Select_Body --
1844    ---------------------------------------
1845
1846    function Make_Disp_Conditional_Select_Body
1847      (Typ : Entity_Id) return Node_Id
1848    is
1849       Loc      : constant Source_Ptr := Sloc (Typ);
1850       Blk_Nam  : Entity_Id;
1851       Conc_Typ : Entity_Id           := Empty;
1852       Decls    : constant List_Id    := New_List;
1853       DT_Ptr   : Entity_Id;
1854       Stmts    : constant List_Id    := New_List;
1855
1856    begin
1857       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1858
1859       --  Null body is generated for interface types
1860
1861       if Is_Interface (Typ) then
1862          return
1863            Make_Subprogram_Body (Loc,
1864              Specification =>
1865                Make_Disp_Conditional_Select_Spec (Typ),
1866              Declarations =>
1867                No_List,
1868              Handled_Statement_Sequence =>
1869                Make_Handled_Sequence_Of_Statements (Loc,
1870                  New_List (Make_Null_Statement (Loc))));
1871       end if;
1872
1873       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1874
1875       if Is_Concurrent_Record_Type (Typ) then
1876          Conc_Typ := Corresponding_Concurrent_Type (Typ);
1877
1878          --  Generate:
1879          --    I : Integer;
1880
1881          --  where I will be used to capture the entry index of the primitive
1882          --  wrapper at position S.
1883
1884          Append_To (Decls,
1885            Make_Object_Declaration (Loc,
1886              Defining_Identifier =>
1887                Make_Defining_Identifier (Loc, Name_uI),
1888              Object_Definition =>
1889                New_Reference_To (Standard_Integer, Loc)));
1890
1891          --  Generate:
1892          --    C := Get_Prim_Op_Kind (tag! (<type>VP), S);
1893
1894          --    if C = POK_Procedure
1895          --      or else C = POK_Protected_Procedure
1896          --      or else C = POK_Task_Procedure;
1897          --    then
1898          --       F := True;
1899          --       return;
1900          --    end if;
1901
1902          SEU.Build_Common_Dispatching_Select_Statements
1903           (Loc, Typ, DT_Ptr, Stmts);
1904
1905          --  Generate:
1906          --    Bnn : Communication_Block;
1907
1908          --  where Bnn is the name of the communication block used in
1909          --  the call to Protected_Entry_Call.
1910
1911          Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
1912
1913          Append_To (Decls,
1914            Make_Object_Declaration (Loc,
1915              Defining_Identifier =>
1916                Blk_Nam,
1917              Object_Definition =>
1918                New_Reference_To (RTE (RE_Communication_Block), Loc)));
1919
1920          --  Generate:
1921          --    I := Get_Entry_Index (tag! (<type>VP), S);
1922
1923          --  I is the entry index and S is the dispatch table slot
1924
1925          Append_To (Stmts,
1926            Make_Assignment_Statement (Loc,
1927              Name =>
1928                Make_Identifier (Loc, Name_uI),
1929              Expression =>
1930                Make_DT_Access_Action (Typ,
1931                  Action =>
1932                    Get_Entry_Index,
1933                  Args =>
1934                    New_List (
1935                      Unchecked_Convert_To (RTE (RE_Tag),
1936                        New_Reference_To (DT_Ptr, Loc)),
1937                      Make_Identifier (Loc, Name_uS)))));
1938
1939          if Ekind (Conc_Typ) = E_Protected_Type then
1940
1941             --  Generate:
1942             --    Protected_Entry_Call (
1943             --      T._object'access,
1944             --      protected_entry_index! (I),
1945             --      P,
1946             --      Conditional_Call,
1947             --      Bnn);
1948
1949             --  where T is the protected object, I is the entry index, P are
1950             --  the wrapped parameters and Bnn is the name of the communication
1951             --  block.
1952
1953             Append_To (Stmts,
1954               Make_Procedure_Call_Statement (Loc,
1955                 Name =>
1956                   New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
1957                 Parameter_Associations =>
1958                   New_List (
1959
1960                     Make_Attribute_Reference (Loc,        -- T._object'access
1961                       Attribute_Name =>
1962                         Name_Unchecked_Access,
1963                       Prefix =>
1964                         Make_Selected_Component (Loc,
1965                           Prefix =>
1966                             Make_Identifier (Loc, Name_uT),
1967                           Selector_Name =>
1968                             Make_Identifier (Loc, Name_uObject))),
1969
1970                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
1971                       Subtype_Mark =>
1972                         New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
1973                       Expression =>
1974                         Make_Identifier (Loc, Name_uI)),
1975
1976                     Make_Identifier (Loc, Name_uP),       --  parameter block
1977                     New_Reference_To (                    --  Conditional_Call
1978                       RTE (RE_Conditional_Call), Loc),
1979                     New_Reference_To (                    --  Bnn
1980                       Blk_Nam, Loc))));
1981
1982             --  Generate:
1983             --    F := not Cancelled (Bnn);
1984
1985             --  where F is the success flag. The status of Cancelled is negated
1986             --  in order to match the behaviour of the version for task types.
1987
1988             Append_To (Stmts,
1989               Make_Assignment_Statement (Loc,
1990                 Name =>
1991                   Make_Identifier (Loc, Name_uF),
1992                 Expression =>
1993                   Make_Op_Not (Loc,
1994                     Right_Opnd =>
1995                       Make_Function_Call (Loc,
1996                         Name =>
1997                           New_Reference_To (RTE (RE_Cancelled), Loc),
1998                         Parameter_Associations =>
1999                           New_List (
2000                             New_Reference_To (Blk_Nam, Loc))))));
2001          else
2002             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2003
2004             --  Generate:
2005             --    Protected_Entry_Call (
2006             --      T._task_id,
2007             --      task_entry_index! (I),
2008             --      P,
2009             --      Conditional_Call,
2010             --      F);
2011
2012             --  where T is the task object, I is the entry index, P are the
2013             --  wrapped parameters and F is the status flag.
2014
2015             Append_To (Stmts,
2016               Make_Procedure_Call_Statement (Loc,
2017                 Name =>
2018                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2019                 Parameter_Associations =>
2020                   New_List (
2021
2022                     Make_Selected_Component (Loc,         -- T._task_id
2023                       Prefix =>
2024                         Make_Identifier (Loc, Name_uT),
2025                       Selector_Name =>
2026                         Make_Identifier (Loc, Name_uTask_Id)),
2027
2028                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2029                       Subtype_Mark =>
2030                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2031                       Expression =>
2032                         Make_Identifier (Loc, Name_uI)),
2033
2034                     Make_Identifier (Loc, Name_uP),       --  parameter block
2035                     New_Reference_To (                    --  Conditional_Call
2036                       RTE (RE_Conditional_Call), Loc),
2037                     Make_Identifier (Loc, Name_uF))));    --  status flag
2038          end if;
2039       end if;
2040
2041       return
2042         Make_Subprogram_Body (Loc,
2043           Specification =>
2044             Make_Disp_Conditional_Select_Spec (Typ),
2045           Declarations =>
2046             Decls,
2047           Handled_Statement_Sequence =>
2048             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2049    end Make_Disp_Conditional_Select_Body;
2050
2051    ---------------------------------------
2052    -- Make_Disp_Conditional_Select_Spec --
2053    ---------------------------------------
2054
2055    function Make_Disp_Conditional_Select_Spec
2056      (Typ : Entity_Id) return Node_Id
2057    is
2058       Loc    : constant Source_Ptr := Sloc (Typ);
2059       Def_Id : constant Node_Id    :=
2060                  Make_Defining_Identifier (Loc,
2061                    Name_uDisp_Conditional_Select);
2062       Params : constant List_Id    := New_List;
2063
2064    begin
2065       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2066
2067       --  "T" - Object parameter
2068       --  "S" - Primitive operation slot
2069       --  "P" - Wrapped parameters
2070       --  "C" - Call kind
2071       --  "F" - Status flag
2072
2073       SEU.Build_T (Loc, Typ, Params);
2074       SEU.Build_S (Loc, Params);
2075       SEU.Build_P (Loc, Params);
2076       SEU.Build_C (Loc, Params);
2077       SEU.Build_F (Loc, Params);
2078
2079       Set_Is_Internal (Def_Id);
2080
2081       return
2082         Make_Procedure_Specification (Loc,
2083           Defining_Unit_Name       => Def_Id,
2084           Parameter_Specifications => Params);
2085    end Make_Disp_Conditional_Select_Spec;
2086
2087    -------------------------------------
2088    -- Make_Disp_Get_Prim_Op_Kind_Body --
2089    -------------------------------------
2090
2091    function Make_Disp_Get_Prim_Op_Kind_Body
2092      (Typ : Entity_Id) return Node_Id
2093    is
2094       Loc    : constant Source_Ptr := Sloc (Typ);
2095       DT_Ptr : Entity_Id;
2096
2097    begin
2098       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2099
2100       if Is_Interface (Typ) then
2101          return
2102            Make_Subprogram_Body (Loc,
2103              Specification =>
2104                Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2105              Declarations =>
2106                New_List,
2107              Handled_Statement_Sequence =>
2108                Make_Handled_Sequence_Of_Statements (Loc,
2109                  New_List (Make_Null_Statement (Loc))));
2110       end if;
2111
2112       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2113
2114       --  Generate:
2115       --    C := get_prim_op_kind (tag! (<type>VP), S);
2116
2117       --  where C is the out parameter capturing the call kind and S is the
2118       --  dispatch table slot number.
2119
2120       return
2121         Make_Subprogram_Body (Loc,
2122           Specification =>
2123             Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2124           Declarations =>
2125             New_List,
2126           Handled_Statement_Sequence =>
2127             Make_Handled_Sequence_Of_Statements (Loc,
2128               New_List (
2129                 Make_Assignment_Statement (Loc,
2130                   Name =>
2131                     Make_Identifier (Loc, Name_uC),
2132                   Expression =>
2133                     Make_DT_Access_Action (Typ,
2134                       Action =>
2135                         Get_Prim_Op_Kind,
2136                       Args =>
2137                         New_List (
2138                           Unchecked_Convert_To (RTE (RE_Tag),
2139                             New_Reference_To (DT_Ptr, Loc)),
2140                             Make_Identifier (Loc, Name_uS)))))));
2141    end Make_Disp_Get_Prim_Op_Kind_Body;
2142
2143    -------------------------------------
2144    -- Make_Disp_Get_Prim_Op_Kind_Spec --
2145    -------------------------------------
2146
2147    function Make_Disp_Get_Prim_Op_Kind_Spec
2148      (Typ : Entity_Id) return Node_Id
2149    is
2150       Loc    : constant Source_Ptr := Sloc (Typ);
2151       Def_Id : constant Node_Id    :=
2152                  Make_Defining_Identifier (Loc,
2153                    Name_uDisp_Get_Prim_Op_Kind);
2154       Params : constant List_Id    := New_List;
2155
2156    begin
2157       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2158
2159       --  "T" - Object parameter
2160       --  "S" - Primitive operation slot
2161       --  "C" - Call kind
2162
2163       SEU.Build_T (Loc, Typ, Params);
2164       SEU.Build_S (Loc, Params);
2165       SEU.Build_C (Loc, Params);
2166
2167       Set_Is_Internal (Def_Id);
2168
2169       return
2170         Make_Procedure_Specification (Loc,
2171            Defining_Unit_Name       => Def_Id,
2172            Parameter_Specifications => Params);
2173    end Make_Disp_Get_Prim_Op_Kind_Spec;
2174
2175    --------------------------------
2176    -- Make_Disp_Get_Task_Id_Body --
2177    --------------------------------
2178
2179    function Make_Disp_Get_Task_Id_Body
2180      (Typ : Entity_Id) return Node_Id
2181    is
2182       Loc : constant Source_Ptr := Sloc (Typ);
2183       Ret : Node_Id;
2184
2185    begin
2186       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2187
2188       if Is_Concurrent_Record_Type (Typ)
2189         and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2190       then
2191          Ret :=
2192            Make_Return_Statement (Loc,
2193              Expression =>
2194                Make_Selected_Component (Loc,
2195                  Prefix =>
2196                    Make_Identifier (Loc, Name_uT),
2197                  Selector_Name =>
2198                    Make_Identifier (Loc, Name_uTask_Id)));
2199
2200       --  A null body is constructed for non-task types
2201
2202       else
2203          Ret :=
2204            Make_Return_Statement (Loc,
2205              Expression =>
2206                New_Reference_To (RTE (RO_ST_Null_Task), Loc));
2207       end if;
2208
2209       return
2210         Make_Subprogram_Body (Loc,
2211           Specification =>
2212             Make_Disp_Get_Task_Id_Spec (Typ),
2213           Declarations =>
2214             New_List,
2215           Handled_Statement_Sequence =>
2216             Make_Handled_Sequence_Of_Statements (Loc,
2217               New_List (Ret)));
2218    end Make_Disp_Get_Task_Id_Body;
2219
2220    --------------------------------
2221    -- Make_Disp_Get_Task_Id_Spec --
2222    --------------------------------
2223
2224    function Make_Disp_Get_Task_Id_Spec
2225      (Typ : Entity_Id) return Node_Id
2226    is
2227       Loc    : constant Source_Ptr := Sloc (Typ);
2228       Def_Id : constant Node_Id    :=
2229                  Make_Defining_Identifier (Loc,
2230                    Name_uDisp_Get_Task_Id);
2231
2232    begin
2233       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2234
2235       Set_Is_Internal (Def_Id);
2236
2237       return
2238         Make_Function_Specification (Loc,
2239           Defining_Unit_Name       => Def_Id,
2240           Parameter_Specifications => New_List (
2241             Make_Parameter_Specification (Loc,
2242               Defining_Identifier =>
2243                 Make_Defining_Identifier (Loc, Name_uT),
2244               Parameter_Type =>
2245                 New_Reference_To (Typ, Loc))),
2246           Result_Definition =>
2247             New_Reference_To (RTE (RO_ST_Task_Id), Loc));
2248    end Make_Disp_Get_Task_Id_Spec;
2249
2250    ---------------------------------
2251    -- Make_Disp_Timed_Select_Body --
2252    ---------------------------------
2253
2254    function Make_Disp_Timed_Select_Body
2255      (Typ : Entity_Id) return Node_Id
2256    is
2257       Loc      : constant Source_Ptr := Sloc (Typ);
2258       Conc_Typ : Entity_Id           := Empty;
2259       Decls    : constant List_Id    := New_List;
2260       DT_Ptr   : Entity_Id;
2261       Stmts    : constant List_Id    := New_List;
2262
2263    begin
2264       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2265
2266       --  Null body is generated for interface types
2267
2268       if Is_Interface (Typ) then
2269          return
2270            Make_Subprogram_Body (Loc,
2271              Specification =>
2272                Make_Disp_Timed_Select_Spec (Typ),
2273              Declarations =>
2274                New_List,
2275              Handled_Statement_Sequence =>
2276                Make_Handled_Sequence_Of_Statements (Loc,
2277                  New_List (Make_Null_Statement (Loc))));
2278       end if;
2279
2280       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2281
2282       if Is_Concurrent_Record_Type (Typ) then
2283          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2284
2285          --  Generate:
2286          --    I : Integer;
2287
2288          --  where I will be used to capture the entry index of the primitive
2289          --  wrapper at position S.
2290
2291          Append_To (Decls,
2292            Make_Object_Declaration (Loc,
2293              Defining_Identifier =>
2294                Make_Defining_Identifier (Loc, Name_uI),
2295              Object_Definition =>
2296                New_Reference_To (Standard_Integer, Loc)));
2297
2298          --  Generate:
2299          --    C := Get_Prim_Op_Kind (tag! (<type>VP), S);
2300
2301          --    if C = POK_Procedure
2302          --      or else C = POK_Protected_Procedure
2303          --      or else C = POK_Task_Procedure;
2304          --    then
2305          --       F := True;
2306          --       return;
2307          --    end if;
2308
2309          SEU.Build_Common_Dispatching_Select_Statements
2310           (Loc, Typ, DT_Ptr, Stmts);
2311
2312          --  Generate:
2313          --    I := Get_Entry_Index (tag! (<type>VP), S);
2314
2315          --  I is the entry index and S is the dispatch table slot
2316
2317          Append_To (Stmts,
2318            Make_Assignment_Statement (Loc,
2319              Name =>
2320                Make_Identifier (Loc, Name_uI),
2321              Expression =>
2322                Make_DT_Access_Action (Typ,
2323                  Action =>
2324                    Get_Entry_Index,
2325                  Args =>
2326                    New_List (
2327                      Unchecked_Convert_To (RTE (RE_Tag),
2328                        New_Reference_To (DT_Ptr, Loc)),
2329                      Make_Identifier (Loc, Name_uS)))));
2330
2331          if Ekind (Conc_Typ) = E_Protected_Type then
2332
2333             --  Generate:
2334             --    Timed_Protected_Entry_Call (
2335             --      T._object'access,
2336             --      protected_entry_index! (I),
2337             --      P,
2338             --      D,
2339             --      M,
2340             --      F);
2341
2342             --  where T is the protected object, I is the entry index, P are
2343             --  the wrapped parameters, D is the delay amount, M is the delay
2344             --  mode and F is the status flag.
2345
2346             Append_To (Stmts,
2347               Make_Procedure_Call_Statement (Loc,
2348                 Name =>
2349                   New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
2350                 Parameter_Associations =>
2351                   New_List (
2352
2353                     Make_Attribute_Reference (Loc,        -- T._object'access
2354                       Attribute_Name =>
2355                         Name_Unchecked_Access,
2356                       Prefix =>
2357                         Make_Selected_Component (Loc,
2358                           Prefix =>
2359                             Make_Identifier (Loc, Name_uT),
2360                           Selector_Name =>
2361                             Make_Identifier (Loc, Name_uObject))),
2362
2363                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2364                       Subtype_Mark =>
2365                         New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
2366                       Expression =>
2367                         Make_Identifier (Loc, Name_uI)),
2368
2369                     Make_Identifier (Loc, Name_uP),       --  parameter block
2370                     Make_Identifier (Loc, Name_uD),       --  delay
2371                     Make_Identifier (Loc, Name_uM),       --  delay mode
2372                     Make_Identifier (Loc, Name_uF))));    --  status flag
2373
2374          else
2375             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2376
2377             --  Generate:
2378             --    Timed_Task_Entry_Call (
2379             --      T._task_id,
2380             --      task_entry_index! (I),
2381             --      P,
2382             --      D,
2383             --      M,
2384             --      F);
2385
2386             --  where T is the task object, I is the entry index, P are the
2387             --  wrapped parameters, D is the delay amount, M is the delay
2388             --  mode and F is the status flag.
2389
2390             Append_To (Stmts,
2391               Make_Procedure_Call_Statement (Loc,
2392                 Name =>
2393                   New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
2394                 Parameter_Associations =>
2395                   New_List (
2396
2397                     Make_Selected_Component (Loc,         --  T._task_id
2398                       Prefix =>
2399                         Make_Identifier (Loc, Name_uT),
2400                       Selector_Name =>
2401                         Make_Identifier (Loc, Name_uTask_Id)),
2402
2403                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2404                       Subtype_Mark =>
2405                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2406                       Expression =>
2407                         Make_Identifier (Loc, Name_uI)),
2408
2409                     Make_Identifier (Loc, Name_uP),       --  parameter block
2410                     Make_Identifier (Loc, Name_uD),       --  delay
2411                     Make_Identifier (Loc, Name_uM),       --  delay mode
2412                     Make_Identifier (Loc, Name_uF))));    --  status flag
2413          end if;
2414       end if;
2415
2416       return
2417         Make_Subprogram_Body (Loc,
2418           Specification =>
2419             Make_Disp_Timed_Select_Spec (Typ),
2420           Declarations =>
2421             Decls,
2422           Handled_Statement_Sequence =>
2423             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2424    end Make_Disp_Timed_Select_Body;
2425
2426    ---------------------------------
2427    -- Make_Disp_Timed_Select_Spec --
2428    ---------------------------------
2429
2430    function Make_Disp_Timed_Select_Spec
2431      (Typ : Entity_Id) return Node_Id
2432    is
2433       Loc    : constant Source_Ptr := Sloc (Typ);
2434       Def_Id : constant Node_Id    :=
2435                  Make_Defining_Identifier (Loc,
2436                    Name_uDisp_Timed_Select);
2437       Params : constant List_Id    := New_List;
2438
2439    begin
2440       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2441
2442       --  "T" - Object parameter
2443       --  "S" - Primitive operation slot
2444       --  "P" - Wrapped parameters
2445       --  "D" - Delay
2446       --  "M" - Delay Mode
2447       --  "C" - Call kind
2448       --  "F" - Status flag
2449
2450       SEU.Build_T (Loc, Typ, Params);
2451       SEU.Build_S (Loc, Params);
2452       SEU.Build_P (Loc, Params);
2453
2454       Append_To (Params,
2455         Make_Parameter_Specification (Loc,
2456           Defining_Identifier =>
2457             Make_Defining_Identifier (Loc, Name_uD),
2458           Parameter_Type =>
2459             New_Reference_To (Standard_Duration, Loc)));
2460
2461       Append_To (Params,
2462         Make_Parameter_Specification (Loc,
2463           Defining_Identifier =>
2464             Make_Defining_Identifier (Loc, Name_uM),
2465           Parameter_Type =>
2466             New_Reference_To (Standard_Integer, Loc)));
2467
2468       SEU.Build_C (Loc, Params);
2469       SEU.Build_F (Loc, Params);
2470
2471       Set_Is_Internal (Def_Id);
2472
2473       return
2474         Make_Procedure_Specification (Loc,
2475           Defining_Unit_Name       => Def_Id,
2476           Parameter_Specifications => Params);
2477    end Make_Disp_Timed_Select_Spec;
2478
2479    -------------
2480    -- Make_DT --
2481    -------------
2482
2483    function Make_DT (Typ : Entity_Id) return List_Id is
2484       Loc         : constant Source_Ptr := Sloc (Typ);
2485       Result      : constant List_Id    := New_List;
2486       Elab_Code   : constant List_Id    := New_List;
2487
2488       Tname       : constant Name_Id := Chars (Typ);
2489       Name_DT     : constant Name_Id := New_External_Name (Tname, 'T');
2490       Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
2491       Name_SSD    : constant Name_Id := New_External_Name (Tname, 'S');
2492       Name_TSD    : constant Name_Id := New_External_Name (Tname, 'B');
2493       Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
2494       Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
2495
2496       --  The following external name is only generated if Typ has interfaces
2497       Name_ITable : Name_Id;
2498
2499       DT     : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
2500       DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
2501       SSD    : constant Node_Id := Make_Defining_Identifier (Loc, Name_SSD);
2502       TSD    : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
2503       Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
2504       No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
2505
2506       Generalized_Tag    : constant Entity_Id := RTE (RE_Tag);
2507       Ancestor_Ifaces    : Elist_Id;
2508       AI                 : Elmt_Id;
2509       Has_Dispatch_Table : Boolean := True;
2510       I_Depth            : Nat := 0;
2511       ITable             : Node_Id;
2512       Iface_Table_Node   : Node_Id;
2513       Nb_Prim            : Nat := 0;
2514       Null_Parent_Tag    : Boolean := False;
2515       Num_Ifaces         : Nat := 0;
2516       Old_Tag1           : Node_Id;
2517       Old_Tag2           : Node_Id;
2518       Parent             : Entity_Id;
2519       Parent_Num_Ifaces  : Nat := 0;
2520       Remotely_Callable  : Entity_Id;
2521       RC_Offset_Node     : Node_Id;
2522       Size_Expr_Node     : Node_Id;
2523       Typ_Ifaces         : Elist_Id;
2524       TSD_Aggr_List      : List_Id;
2525
2526    begin
2527       if not RTE_Available (RE_Tag) then
2528          Error_Msg_CRT ("tagged types", Typ);
2529          return New_List;
2530       end if;
2531
2532       --  Ensure that the unit System_Storage_Elements is loaded. This is
2533       --  required to properly expand the routines of Ada.Tags
2534
2535       if not RTU_Loaded (System_Storage_Elements)
2536         and then not Present (RTE (RE_Storage_Offset))
2537       then
2538          raise Program_Error;
2539       end if;
2540
2541       if Ada_Version >= Ada_05 then
2542
2543          --  Count the interface types of the parents
2544
2545          Parent := Empty;
2546
2547          if Typ /= Etype (Typ) then
2548             Parent := Etype (Typ);
2549
2550          elsif Is_Concurrent_Record_Type (Typ) then
2551             Parent := Etype (First (Abstract_Interface_List (Typ)));
2552          end if;
2553
2554          if Present (Parent) then
2555             Collect_Abstract_Interfaces (Parent, Ancestor_Ifaces);
2556
2557             AI := First_Elmt (Ancestor_Ifaces);
2558             while Present (AI) loop
2559                Parent_Num_Ifaces := Parent_Num_Ifaces + 1;
2560                Next_Elmt (AI);
2561             end loop;
2562          end if;
2563
2564          --  Count the additional interfaces implemented by Typ
2565
2566          Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
2567
2568          AI := First_Elmt (Typ_Ifaces);
2569          while Present (AI) loop
2570             Num_Ifaces := Num_Ifaces + 1;
2571             Next_Elmt (AI);
2572          end loop;
2573       end if;
2574
2575       --  Count ancestors to compute the inheritance depth. For private
2576       --  extensions, always go to the full view in order to compute the
2577       --  real inheritance depth.
2578
2579       declare
2580          Parent_Type : Entity_Id := Typ;
2581          P           : Entity_Id;
2582
2583       begin
2584          I_Depth := 0;
2585          loop
2586             P := Etype (Parent_Type);
2587
2588             if Is_Private_Type (P) then
2589                P := Full_View (Base_Type (P));
2590             end if;
2591
2592             exit when P = Parent_Type;
2593
2594             I_Depth := I_Depth + 1;
2595             Parent_Type := P;
2596          end loop;
2597       end;
2598
2599       --  Calculate the number of primitives of the dispatch table and the
2600       --  size of the Type_Specific_Data record.
2601
2602       --  Abstract interfaces don't need the dispatch table. In addition,
2603       --  compiling with restriction No_Dispatching_Calls we do not generate
2604       --  the dispatch table.
2605
2606       Has_Dispatch_Table :=
2607         not Is_Interface (Typ)
2608           and then not Restriction_Active (No_Dispatching_Calls);
2609
2610       if Has_Dispatch_Table then
2611          Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
2612       end if;
2613
2614       --  Dispatch table and related entities are allocated statically
2615
2616       Set_Ekind (DT, E_Variable);
2617       Set_Is_Statically_Allocated (DT);
2618
2619       Set_Ekind (DT_Ptr, E_Variable);
2620       Set_Is_Statically_Allocated (DT_Ptr);
2621
2622       if Num_Ifaces > 0 then
2623          Name_ITable := New_External_Name (Tname, 'I');
2624          ITable      := Make_Defining_Identifier (Loc, Name_ITable);
2625
2626          Set_Ekind (ITable, E_Variable);
2627          Set_Is_Statically_Allocated (ITable);
2628       end if;
2629
2630       Set_Ekind (SSD, E_Variable);
2631       Set_Is_Statically_Allocated (SSD);
2632
2633       Set_Ekind (TSD, E_Variable);
2634       Set_Is_Statically_Allocated (TSD);
2635
2636       Set_Ekind (Exname, E_Variable);
2637       Set_Is_Statically_Allocated (Exname);
2638
2639       Set_Ekind (No_Reg, E_Variable);
2640       Set_Is_Statically_Allocated (No_Reg);
2641
2642       --  Generate code to create the storage for the Dispatch_Table object:
2643
2644       --   DT : Storage_Array (1 .. Size_Expr);
2645       --   for DT'Alignment use Address'Alignment
2646
2647       --  Under No_Dispatching_Calls the size of the table is small just
2648       --  containing:
2649       --   1) the pointer to the TSD
2650       --   2) a dummy entry used as the Tag of the type (see a-tags.ads).
2651
2652       if not Has_Dispatch_Table then
2653          Size_Expr_Node :=
2654            New_Reference_To (RTE (RE_DT_Min_Prologue_Size), Loc);
2655
2656       --  If the object has no primitives we ensure that the table will
2657       --  have at least a dummy entry which will be used as the Tag.
2658
2659       --   Size_Expr := DT_Prologue_Size + DT_Entry_Size
2660
2661       elsif Nb_Prim = 0 then
2662          Size_Expr_Node :=
2663            Make_Op_Add (Loc,
2664              Left_Opnd  =>
2665                New_Reference_To (RTE (RE_DT_Prologue_Size), Loc),
2666              Right_Opnd =>
2667                New_Reference_To (RTE (RE_DT_Entry_Size), Loc));
2668
2669       --  Common case. The dispatch table has space to save the pointers to
2670       --  all the predefined primitives, the C++ ABI header of the DT, and
2671       --  the pointers to the primitives of Typ. That is,
2672
2673       --   Size_Expr := DT_Prologue_Size + nb_prim * DT_Entry_Size
2674
2675       else
2676          Size_Expr_Node :=
2677            Make_Op_Add (Loc,
2678              Left_Opnd  =>
2679                New_Reference_To (RTE (RE_DT_Prologue_Size), Loc),
2680              Right_Opnd =>
2681                Make_Op_Multiply (Loc,
2682                  Left_Opnd  =>
2683                    New_Reference_To (RTE (RE_DT_Entry_Size), Loc),
2684                  Right_Opnd =>
2685                    Make_Integer_Literal (Loc, Nb_Prim)));
2686       end if;
2687
2688       Append_To (Result,
2689         Make_Object_Declaration (Loc,
2690           Defining_Identifier => DT,
2691           Aliased_Present     => True,
2692           Object_Definition   =>
2693             Make_Subtype_Indication (Loc,
2694               Subtype_Mark => New_Reference_To
2695                                 (RTE (RE_Storage_Array), Loc),
2696               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
2697                 Constraints => New_List (
2698                   Make_Range (Loc,
2699                     Low_Bound  => Make_Integer_Literal (Loc, 1),
2700                     High_Bound => Size_Expr_Node))))));
2701
2702       Append_To (Result,
2703         Make_Attribute_Definition_Clause (Loc,
2704           Name       => New_Reference_To (DT, Loc),
2705           Chars      => Name_Alignment,
2706           Expression =>
2707             Make_Attribute_Reference (Loc,
2708               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
2709               Attribute_Name => Name_Alignment)));
2710
2711       --  Generate code to create the pointer to the dispatch table
2712
2713       --    DT_Ptr : Tag := Tag!(DT'Address);
2714
2715       --  According to the C++ ABI, the base of the vtable is located after a
2716       --  prologue containing Offset_To_Top, and Typeinfo_Ptr. Hence, we move
2717       --  down the pointer to the real base of the vtable
2718
2719       if not Has_Dispatch_Table then
2720          Append_To (Result,
2721            Make_Object_Declaration (Loc,
2722              Defining_Identifier => DT_Ptr,
2723              Constant_Present    => True,
2724              Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
2725              Expression          =>
2726                Unchecked_Convert_To (Generalized_Tag,
2727                  Make_Op_Add (Loc,
2728                    Left_Opnd =>
2729                      Unchecked_Convert_To (RTE (RE_Storage_Offset),
2730                        Make_Attribute_Reference (Loc,
2731                          Prefix         => New_Reference_To (DT, Loc),
2732                          Attribute_Name => Name_Address)),
2733                    Right_Opnd =>
2734                      New_Reference_To (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))));
2735
2736       else
2737          Append_To (Result,
2738            Make_Object_Declaration (Loc,
2739              Defining_Identifier => DT_Ptr,
2740              Constant_Present    => True,
2741              Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
2742              Expression          =>
2743                Unchecked_Convert_To (Generalized_Tag,
2744                  Make_Op_Add (Loc,
2745                    Left_Opnd =>
2746                      Unchecked_Convert_To (RTE (RE_Storage_Offset),
2747                        Make_Attribute_Reference (Loc,
2748                          Prefix         => New_Reference_To (DT, Loc),
2749                          Attribute_Name => Name_Address)),
2750                    Right_Opnd =>
2751                      New_Reference_To (RTE (RE_DT_Prologue_Size), Loc)))));
2752       end if;
2753
2754       --  Save the tag in the Access_Disp_Table attribute
2755
2756       if No (Access_Disp_Table (Typ)) then
2757          Set_Access_Disp_Table (Typ, New_Elmt_List);
2758       end if;
2759
2760       Prepend_Elmt (DT_Ptr, Access_Disp_Table (Typ));
2761
2762       --  Generate code to define the boolean that controls registration, in
2763       --  order to avoid multiple registrations for tagged types defined in
2764       --  multiple-called scopes.
2765
2766       Append_To (Result,
2767         Make_Object_Declaration (Loc,
2768           Defining_Identifier => No_Reg,
2769           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
2770           Expression          => New_Reference_To (Standard_True, Loc)));
2771
2772       --  Generate:
2773       --    Set_Signature (DT_Ptr, Value);
2774
2775       if Has_Dispatch_Table
2776         and then RTE_Available (RE_Set_Signature)
2777       then
2778          if Is_Interface (Typ) then
2779             Append_To (Elab_Code,
2780               Make_DT_Access_Action (Typ,
2781                 Action => Set_Signature,
2782                 Args   => New_List (
2783                   New_Reference_To (DT_Ptr, Loc),
2784                   New_Reference_To (RTE (RE_Abstract_Interface), Loc))));
2785
2786          else
2787             Append_To (Elab_Code,
2788               Make_DT_Access_Action (Typ,
2789                 Action => Set_Signature,
2790                 Args   => New_List (
2791                   New_Reference_To (DT_Ptr, Loc),
2792                   New_Reference_To (RTE (RE_Primary_DT), Loc))));
2793          end if;
2794       end if;
2795
2796       --  Generate: Exname : constant String := full_qualified_name (typ);
2797       --  The type itself may be an anonymous parent type, so use the first
2798       --  subtype to have a user-recognizable name.
2799
2800       Append_To (Result,
2801         Make_Object_Declaration (Loc,
2802           Defining_Identifier => Exname,
2803           Constant_Present    => True,
2804           Object_Definition   => New_Reference_To (Standard_String, Loc),
2805           Expression =>
2806             Make_String_Literal (Loc,
2807               Full_Qualified_Name (First_Subtype (Typ)))));
2808
2809       --  Calculate the value of the RC_Offset component. These are the
2810       --  valid valiues and their meaning:
2811       --   >0: For simple types with controlled components is
2812       --         type._record_controller'position
2813       --    0: For types with no controlled components
2814       --   -1: For complex types with controlled components where the position
2815       --       of the record controller is not statically computable but there
2816       --       are controlled components at this level. The _Controller field
2817       --       is available right after the _parent.
2818       --   -2: There are no controlled components at this level. We need to
2819       --       get the position from the parent.
2820
2821       if Is_Interface (Typ)
2822         or else not Has_Controlled_Component (Typ)
2823       then
2824          RC_Offset_Node := Make_Integer_Literal (Loc, 0);
2825
2826       elsif Etype (Typ) /= Typ
2827         and then Has_Discriminants (Etype (Typ))
2828       then
2829          if Has_New_Controlled_Component (Typ) then
2830             RC_Offset_Node := Make_Integer_Literal (Loc, -1);
2831          else
2832             RC_Offset_Node := Make_Integer_Literal (Loc, -2);
2833          end if;
2834       else
2835          RC_Offset_Node :=
2836            Make_Attribute_Reference (Loc,
2837              Prefix =>
2838                Make_Selected_Component (Loc,
2839                  Prefix => New_Reference_To (Typ, Loc),
2840                  Selector_Name =>
2841                    New_Reference_To (Controller_Component (Typ), Loc)),
2842              Attribute_Name => Name_Position);
2843
2844          --  This is not proper Ada code to use the attribute 'Position
2845          --  on something else than an object but this is supported by
2846          --  the back end (see comment on the Bit_Component attribute in
2847          --  sem_attr). So we avoid semantic checking here.
2848
2849          --  Is this documented in sinfo.ads??? it should be!
2850
2851          Set_Analyzed (RC_Offset_Node);
2852          Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
2853          Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
2854          Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
2855            RTE (RE_Record_Controller));
2856          Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
2857       end if;
2858
2859       --  Set the pointer to the Interfaces_Table (if any). Otherwise the
2860       --  corresponding access component is set to null. The table of
2861       --  interfaces is required for AI-405
2862
2863       if RTE_Record_Component_Available (RE_Ifaces_Table_Ptr) then
2864          if Num_Ifaces = 0 then
2865             Iface_Table_Node :=
2866               New_Reference_To (RTE (RE_Null_Address), Loc);
2867
2868          --  Generate the Interface_Table object.
2869
2870          else
2871             Append_To (Result,
2872               Make_Object_Declaration (Loc,
2873                 Defining_Identifier => ITable,
2874                 Aliased_Present     => True,
2875                 Object_Definition   =>
2876                   Make_Subtype_Indication (Loc,
2877                     Subtype_Mark => New_Reference_To
2878                       (RTE (RE_Interface_Data), Loc),
2879                     Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
2880                       Constraints => New_List (
2881                         Make_Integer_Literal (Loc,
2882                           Num_Ifaces))))));
2883
2884             Iface_Table_Node :=
2885               Make_Attribute_Reference (Loc,
2886                 Prefix         => New_Reference_To (ITable, Loc),
2887                 Attribute_Name => Name_Address);
2888          end if;
2889       end if;
2890
2891       --  Generate: Set_Remotely_Callable (DT_Ptr, Status); where Status is
2892       --  described in E.4 (18)
2893
2894       Remotely_Callable :=
2895         Boolean_Literals
2896           (Is_Pure (Typ)
2897              or else Is_Shared_Passive (Typ)
2898              or else
2899                ((Is_Remote_Types (Typ)
2900                    or else Is_Remote_Call_Interface (Typ))
2901                 and then Original_View_In_Visible_Part (Typ))
2902              or else not Comes_From_Source (Typ));
2903
2904       --  Generate code to create the storage for the type specific data object
2905       --  with enough space to store the tags of the ancestors plus the tags
2906       --  of all the implemented interfaces (as described in a-tags.adb).
2907
2908       --   TSD : Type_Specific_Data (I_Depth) :=
2909       --           (Idepth        => I_Depth,
2910       --            Access_Level  => Type_Access_Level (Typ),
2911       --            Expanded_Name => Cstring_Ptr!(Exname'Address))
2912       --            [ External_Tag  => Cstring_Ptr!(Exname'Address)) ]
2913       --            RC_Offset     => <<integer-value>>,
2914       --            Remotely_Callable => <<boolean-value>>
2915       --            [ Ifaces_Table_Ptr => <<access-value>> ]
2916       --            others => <>);
2917       --   for TSD'Alignment use Address'Alignment
2918
2919       TSD_Aggr_List := New_List (
2920         Make_Component_Association (Loc,
2921           Choices => New_List (
2922             New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)),
2923           Expression => Make_Integer_Literal (Loc, I_Depth)),
2924
2925         Make_Component_Association (Loc,
2926           Choices => New_List (
2927             New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)),
2928           Expression => Make_Integer_Literal (Loc, Type_Access_Level (Typ))),
2929
2930         Make_Component_Association (Loc,
2931           Choices => New_List (
2932             New_Occurrence_Of
2933               (RTE_Record_Component (RE_Expanded_Name), Loc)),
2934           Expression =>
2935             Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
2936               Make_Attribute_Reference (Loc,
2937                 Prefix => New_Reference_To (Exname, Loc),
2938                 Attribute_Name => Name_Address))));
2939
2940       if not Has_External_Tag_Rep_Clause (Typ) then
2941
2942          --  Should be the external name not the qualified name???
2943
2944          Append_To (TSD_Aggr_List,
2945            Make_Component_Association (Loc,
2946              Choices => New_List (
2947                New_Occurrence_Of
2948                  (RTE_Record_Component (RE_External_Tag), Loc)),
2949              Expression =>
2950                Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
2951                  Make_Attribute_Reference (Loc,
2952                    Prefix => New_Reference_To (Exname, Loc),
2953                    Attribute_Name => Name_Address))));
2954       end if;
2955
2956       Append_List_To (TSD_Aggr_List, New_List (
2957         Make_Component_Association (Loc,
2958           Choices => New_List (
2959             New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)),
2960           Expression => RC_Offset_Node),
2961
2962         Make_Component_Association (Loc,
2963           Choices => New_List (
2964             New_Occurrence_Of
2965              (RTE_Record_Component (RE_Remotely_Callable), Loc)),
2966           Expression => New_Occurrence_Of (Remotely_Callable, Loc))));
2967
2968       if RTE_Record_Component_Available (RE_Ifaces_Table_Ptr) then
2969          Append_To (TSD_Aggr_List,
2970            Make_Component_Association (Loc,
2971              Choices => New_List (
2972                New_Occurrence_Of
2973                 (RTE_Record_Component (RE_Ifaces_Table_Ptr), Loc)),
2974              Expression => Iface_Table_Node));
2975       end if;
2976
2977       Append_To (TSD_Aggr_List,
2978         Make_Component_Association (Loc,
2979           Choices     => New_List (Make_Others_Choice (Loc)),
2980           Expression  => Empty,
2981           Box_Present => True));
2982
2983       --  Save the expanded name in the dispatch table
2984
2985       Append_To (Result,
2986         Make_Object_Declaration (Loc,
2987           Defining_Identifier => TSD,
2988           Aliased_Present     => True,
2989           Object_Definition   =>
2990             Make_Subtype_Indication (Loc,
2991               Subtype_Mark => New_Reference_To (
2992                 RTE (RE_Type_Specific_Data), Loc),
2993               Constraint =>
2994                 Make_Index_Or_Discriminant_Constraint (Loc,
2995                   Constraints => New_List (
2996                     Make_Integer_Literal (Loc, I_Depth)))),
2997           Expression => Make_Aggregate (Loc,
2998             Component_Associations => TSD_Aggr_List)));
2999
3000       Append_To (Result,
3001         Make_Attribute_Definition_Clause (Loc,
3002           Name       => New_Reference_To (TSD, Loc),
3003           Chars      => Name_Alignment,
3004           Expression =>
3005             Make_Attribute_Reference (Loc,
3006               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
3007               Attribute_Name => Name_Alignment)));
3008
3009       --  Generate code to put the Address of the TSD in the dispatch table
3010
3011       Append_To (Elab_Code,
3012         Build_Set_TSD (Loc,
3013           Tag_Node => New_Reference_To (DT_Ptr, Loc),
3014           Value_Node =>
3015             Make_Attribute_Reference (Loc,
3016               Prefix          => New_Reference_To (TSD, Loc),
3017               Attribute_Name  => Name_Address)));
3018
3019       --  Generate extra code required for synchronized interfaces
3020
3021       if RTE_Available (RE_Set_Tagged_Kind) then
3022          if Ada_Version >= Ada_05
3023            and then not Is_Interface  (Typ)
3024            and then not Is_Abstract_Type   (Typ)
3025            and then not Is_Controlled (Typ)
3026            and then not Restriction_Active (No_Dispatching_Calls)
3027          then
3028             --  Generate:
3029             --    Set_Type_Kind (T'Tag, Type_Kind (Typ));
3030
3031             Append_To (Elab_Code,
3032               Make_DT_Access_Action (Typ,
3033                 Action => Set_Tagged_Kind,
3034                 Args   => New_List (
3035                   New_Reference_To (DT_Ptr, Loc),               -- DTptr
3036                   Tagged_Kind (Typ))));                         -- Value
3037
3038             --  Generate the Select Specific Data table for synchronized
3039             --  types that implement a synchronized interface. The size
3040             --  of the table is constrained by the number of non-predefined
3041             --  primitive operations.
3042
3043             if Has_Dispatch_Table
3044               and then Is_Concurrent_Record_Type (Typ)
3045               and then Has_Abstract_Interfaces (Typ)
3046             then
3047                --  No need to generate this code if Nb_Prim = 0 ???
3048
3049                Append_To (Result,
3050                  Make_Object_Declaration (Loc,
3051                    Defining_Identifier => SSD,
3052                    Aliased_Present     => True,
3053                    Object_Definition   =>
3054                      Make_Subtype_Indication (Loc,
3055                        Subtype_Mark => New_Reference_To (
3056                          RTE (RE_Select_Specific_Data), Loc),
3057                        Constraint   =>
3058                          Make_Index_Or_Discriminant_Constraint (Loc,
3059                            Constraints => New_List (
3060                              Make_Integer_Literal (Loc, Nb_Prim))))));
3061
3062                --  Set the pointer to the Select Specific Data table in the TSD
3063
3064                Append_To (Elab_Code,
3065                  Make_DT_Access_Action (Typ,
3066                    Action => Set_SSD,
3067                    Args   => New_List (
3068                      New_Reference_To (DT_Ptr, Loc),            -- DTptr
3069                      Make_Attribute_Reference (Loc,             -- Value
3070                        Prefix         => New_Reference_To (SSD, Loc),
3071                        Attribute_Name => Name_Address))));
3072             end if;
3073          end if;
3074       end if;
3075
3076       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
3077       --  in the init proc, and we don't need to fill them in here.
3078
3079       if Is_CPP_Class (Etype (Typ)) then
3080          null;
3081
3082          --  Otherwise we fill in the dispatch tables here
3083
3084       else
3085          if Typ = Etype (Typ)
3086            or else Is_CPP_Class (Etype (Typ))
3087            or else Is_Interface (Typ)
3088          then
3089             Null_Parent_Tag := True;
3090
3091             Old_Tag1 :=
3092               Unchecked_Convert_To (Generalized_Tag,
3093                 Make_Integer_Literal (Loc, 0));
3094             Old_Tag2 :=
3095               Unchecked_Convert_To (Generalized_Tag,
3096                 Make_Integer_Literal (Loc, 0));
3097
3098          else
3099             Old_Tag1 :=
3100               New_Reference_To
3101                 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
3102             Old_Tag2 :=
3103               New_Reference_To
3104                 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
3105          end if;
3106
3107          if Typ /= Etype (Typ)
3108            and then not Is_Interface (Typ)
3109            and then not Restriction_Active (No_Dispatching_Calls)
3110          then
3111             --  Inherit the dispatch table
3112
3113             if not Is_Interface (Etype (Typ)) then
3114                if Restriction_Active (No_Dispatching_Calls) then
3115                   null;
3116
3117                else
3118                   if not Null_Parent_Tag then
3119                      declare
3120                         Nb_Prims : constant Int :=
3121                                      UI_To_Int (DT_Entry_Count
3122                                        (First_Tag_Component (Etype (Typ))));
3123                      begin
3124                         Append_To (Elab_Code,
3125                           Build_Inherit_Predefined_Prims (Loc,
3126                             Old_Tag_Node => Old_Tag1,
3127                             New_Tag_Node =>
3128                               New_Reference_To (DT_Ptr, Loc)));
3129
3130                         if Nb_Prims /= 0 then
3131                            Append_To (Elab_Code,
3132                              Build_Inherit_Prims (Loc,
3133                                Old_Tag_Node => Old_Tag2,
3134                                New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
3135                                Num_Prims    => Nb_Prims));
3136                         end if;
3137                      end;
3138                   end if;
3139                end if;
3140             end if;
3141
3142             --  Inherit the secondary dispatch tables of the ancestor
3143
3144             if not Restriction_Active (No_Dispatching_Calls)
3145               and then not Is_CPP_Class (Etype (Typ))
3146             then
3147                declare
3148                   Sec_DT_Ancestor : Elmt_Id :=
3149                                       Next_Elmt
3150                                         (First_Elmt
3151                                            (Access_Disp_Table (Etype (Typ))));
3152                   Sec_DT_Typ      : Elmt_Id :=
3153                                       Next_Elmt
3154                                         (First_Elmt
3155                                            (Access_Disp_Table (Typ)));
3156
3157                   procedure Copy_Secondary_DTs (Typ : Entity_Id);
3158                   --  Local procedure required to climb through the ancestors
3159                   --  and copy the contents of all their secondary dispatch
3160                   --  tables.
3161
3162                   ------------------------
3163                   -- Copy_Secondary_DTs --
3164                   ------------------------
3165
3166                   procedure Copy_Secondary_DTs (Typ : Entity_Id) is
3167                      E     : Entity_Id;
3168                      Iface : Elmt_Id;
3169
3170                   begin
3171                      --  Climb to the ancestor (if any) handling private types
3172
3173                      if Present (Full_View (Etype (Typ))) then
3174                         if Full_View (Etype (Typ)) /= Typ then
3175                            Copy_Secondary_DTs (Full_View (Etype (Typ)));
3176                         end if;
3177
3178                      elsif Etype (Typ) /= Typ then
3179                         Copy_Secondary_DTs (Etype (Typ));
3180                      end if;
3181
3182                      if Present (Abstract_Interfaces (Typ))
3183                        and then not Is_Empty_Elmt_List
3184                                       (Abstract_Interfaces (Typ))
3185                      then
3186                         Iface := First_Elmt (Abstract_Interfaces (Typ));
3187                         E     := First_Entity (Typ);
3188                         while Present (E)
3189                           and then Present (Node (Sec_DT_Ancestor))
3190                         loop
3191                            if Is_Tag (E) and then Chars (E) /= Name_uTag then
3192                               if not Is_Interface (Etype (Typ)) then
3193
3194                                  --  Inherit the dispatch table
3195
3196                                  declare
3197                                     Num_Prims : constant Int :=
3198                                                 UI_To_Int (DT_Entry_Count (E));
3199                                  begin
3200                                     Append_To (Elab_Code,
3201                                       Build_Inherit_Predefined_Prims (Loc,
3202                                         Old_Tag_Node =>
3203                                           Unchecked_Convert_To (RTE (RE_Tag),
3204                                              New_Reference_To
3205                                                (Node (Sec_DT_Ancestor), Loc)),
3206                                         New_Tag_Node =>
3207                                           Unchecked_Convert_To (RTE (RE_Tag),
3208                                             New_Reference_To
3209                                               (Node (Sec_DT_Typ), Loc))));
3210
3211                                     if Num_Prims /= 0 then
3212                                        Append_To (Elab_Code,
3213                                          Build_Inherit_Prims (Loc,
3214                                            Old_Tag_Node =>
3215                                              Unchecked_Convert_To
3216                                                (RTE (RE_Tag),
3217                                                 New_Reference_To
3218                                                   (Node (Sec_DT_Ancestor),
3219                                                    Loc)),
3220                                            New_Tag_Node =>
3221                                              Unchecked_Convert_To
3222                                               (RTE (RE_Tag),
3223                                                New_Reference_To
3224                                                  (Node (Sec_DT_Typ), Loc)),
3225                                            Num_Prims => Num_Prims));
3226                                     end if;
3227                                  end;
3228                               end if;
3229
3230                               Next_Elmt (Sec_DT_Ancestor);
3231                               Next_Elmt (Sec_DT_Typ);
3232                               Next_Elmt (Iface);
3233                            end if;
3234
3235                            Next_Entity (E);
3236                         end loop;
3237                      end if;
3238                   end Copy_Secondary_DTs;
3239
3240                begin
3241                   if Present (Node (Sec_DT_Ancestor)) then
3242
3243                      --  Handle private types
3244
3245                      if Present (Full_View (Typ)) then
3246                         Copy_Secondary_DTs (Full_View (Typ));
3247                      else
3248                         Copy_Secondary_DTs (Typ);
3249                      end if;
3250                   end if;
3251                end;
3252             end if;
3253          end if;
3254
3255          --  Generate:
3256          --    Inherit_TSD (parent'tag, DT_Ptr);
3257
3258          if not Is_Interface (Typ) then
3259             if Typ = Etype (Typ)
3260               or else Is_CPP_Class (Etype (Typ))
3261             then
3262                --  New_TSD (DT_Ptr);
3263
3264                Append_List_To (Elab_Code,
3265                  Build_New_TSD (Loc,
3266                    New_Tag_Node => New_Reference_To (DT_Ptr, Loc)));
3267             else
3268                --  Inherit_TSD (parent'tag, DT_Ptr);
3269
3270                Append_To (Elab_Code,
3271                  Build_Inherit_TSD (Loc,
3272                    Old_Tag_Node =>
3273                      New_Reference_To
3274                        (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))),
3275                         Loc),
3276                    New_Tag_Node      => New_Reference_To (DT_Ptr, Loc),
3277                    I_Depth           => I_Depth,
3278                    Parent_Num_Ifaces => Parent_Num_Ifaces));
3279             end if;
3280          end if;
3281       end if;
3282
3283       if not Is_Interface (Typ)
3284         and then RTE_Available (RE_Set_Offset_To_Top)
3285       then
3286          --  Generate:
3287          --    Set_Offset_To_Top (0, DT_Ptr, True, 0, null);
3288
3289          Append_To (Elab_Code,
3290            Make_Procedure_Call_Statement (Loc,
3291              Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
3292              Parameter_Associations => New_List (
3293                New_Reference_To (RTE (RE_Null_Address), Loc),
3294                New_Reference_To (DT_Ptr, Loc),
3295                New_Occurrence_Of (Standard_True, Loc),
3296                Make_Integer_Literal (Loc, Uint_0),
3297                New_Reference_To (RTE (RE_Null_Address), Loc))));
3298       end if;
3299
3300       --  Generate code to register the Tag in the External_Tag hash table for
3301       --  the pure Ada type only.
3302
3303       --        Register_Tag (Dt_Ptr);
3304
3305       --  Skip this if routine not available, or in No_Run_Time mode or Typ is
3306       --  an abstract interface type (because the table to register it is not
3307       --  available in the abstract type but in types implementing this
3308       --  interface)
3309
3310       if not Has_External_Tag_Rep_Clause (Typ)
3311         and then not No_Run_Time_Mode
3312         and then RTE_Available (RE_Register_Tag)
3313         and then Is_RTE (RTE (RE_Tag), RE_Tag)
3314         and then not Is_Interface (Typ)
3315       then
3316          Append_To (Elab_Code,
3317            Make_Procedure_Call_Statement (Loc,
3318              Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
3319              Parameter_Associations =>
3320                New_List (New_Reference_To (DT_Ptr, Loc))));
3321       end if;
3322
3323       --  Generate:
3324       --     if No_Reg then
3325       --        <elab_code>
3326       --        No_Reg := False;
3327       --     end if;
3328
3329       Append_To (Elab_Code,
3330         Make_Assignment_Statement (Loc,
3331           Name       => New_Reference_To (No_Reg, Loc),
3332           Expression => New_Reference_To (Standard_False, Loc)));
3333
3334       Append_To (Result,
3335         Make_Implicit_If_Statement (Typ,
3336           Condition       => New_Reference_To (No_Reg, Loc),
3337           Then_Statements => Elab_Code));
3338
3339       --  Ada 2005 (AI-251): Register the tag of the interfaces into the table
3340       --  of interfaces.
3341
3342       if Num_Ifaces > 0 then
3343          declare
3344             Position : Nat;
3345
3346          begin
3347             --  If the parent is an interface we must generate code to register
3348             --  all its interfaces; otherwise this code is not needed because
3349             --  Inherit_TSD has already inherited such interfaces.
3350
3351             if Is_Concurrent_Record_Type (Typ)
3352               or else (Etype (Typ) /= Typ and then Is_Interface (Etype (Typ)))
3353             then
3354                Position := 1;
3355
3356                AI := First_Elmt (Ancestor_Ifaces);
3357                while Present (AI) loop
3358                   --  Generate:
3359                   --    Register_Interface (DT_Ptr, Interface'Tag);
3360
3361                   Append_To (Result,
3362                     Make_DT_Access_Action (Typ,
3363                       Action => Register_Interface_Tag,
3364                       Args   => New_List (
3365                         Node1 => New_Reference_To (DT_Ptr, Loc),
3366                         Node2 => New_Reference_To
3367                                    (Node
3368                                     (First_Elmt
3369                                      (Access_Disp_Table (Node (AI)))),
3370                                     Loc),
3371                         Node3 => Make_Integer_Literal (Loc, Position))));
3372
3373                   Position := Position + 1;
3374                   Next_Elmt (AI);
3375                end loop;
3376             end if;
3377
3378             --  Register the interfaces that are not implemented by the
3379             --  ancestor
3380
3381             AI := First_Elmt (Typ_Ifaces);
3382
3383             --  Skip the interfaces implemented by the ancestor
3384
3385             for Count in 1 .. Parent_Num_Ifaces loop
3386                Next_Elmt (AI);
3387             end loop;
3388
3389             --  Register the additional interfaces
3390
3391             Position := Parent_Num_Ifaces + 1;
3392             while Present (AI) loop
3393
3394                --  Generate:
3395                --    Register_Interface (DT_Ptr, Interface'Tag);
3396
3397                if not Is_Interface (Typ)
3398                  or else Typ /= Node (AI)
3399                then
3400                   Append_To (Result,
3401                     Make_DT_Access_Action (Typ,
3402                       Action => Register_Interface_Tag,
3403                       Args   => New_List (
3404                         Node1 => New_Reference_To (DT_Ptr, Loc),
3405                         Node2 => New_Reference_To
3406                                    (Node
3407                                     (First_Elmt
3408                                      (Access_Disp_Table (Node (AI)))),
3409                                     Loc),
3410                         Node3 => Make_Integer_Literal (Loc, Position))));
3411
3412                   Position := Position + 1;
3413                end if;
3414
3415                Next_Elmt (AI);
3416             end loop;
3417
3418             pragma Assert (Position = Num_Ifaces + 1);
3419          end;
3420       end if;
3421
3422       return Result;
3423    end Make_DT;
3424
3425    ---------------------------
3426    -- Make_DT_Access_Action --
3427    ---------------------------
3428
3429    function Make_DT_Access_Action
3430      (Typ    : Entity_Id;
3431       Action : DT_Access_Action;
3432       Args   : List_Id) return Node_Id
3433    is
3434       Action_Name : constant Entity_Id := RTE (Ada_Actions (Action));
3435       Loc         : Source_Ptr;
3436
3437    begin
3438       if No (Args) then
3439
3440          --  This is a constant
3441
3442          return New_Reference_To (Action_Name, Sloc (Typ));
3443       end if;
3444
3445       pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
3446
3447       Loc := Sloc (First (Args));
3448
3449       if Action_Is_Proc (Action) then
3450          return
3451            Make_Procedure_Call_Statement (Loc,
3452              Name => New_Reference_To (Action_Name, Loc),
3453              Parameter_Associations => Args);
3454
3455       else
3456          return
3457            Make_Function_Call (Loc,
3458              Name => New_Reference_To (Action_Name, Loc),
3459              Parameter_Associations => Args);
3460       end if;
3461    end Make_DT_Access_Action;
3462
3463    -----------------------
3464    -- Make_Secondary_DT --
3465    -----------------------
3466
3467    procedure Make_Secondary_DT
3468      (Typ             : Entity_Id;
3469       Ancestor_Typ    : Entity_Id;
3470       Suffix_Index    : Nat;
3471       Iface           : Entity_Id;
3472       AI_Tag          : Entity_Id;
3473       Acc_Disp_Tables : in out Elist_Id;
3474       Result          : out List_Id)
3475    is
3476       Loc             : constant Source_Ptr := Sloc (AI_Tag);
3477       Generalized_Tag : constant Entity_Id := RTE (RE_Interface_Tag);
3478       Name_DT         : constant Name_Id := New_Internal_Name ('T');
3479       Empty_DT        : Boolean := False;
3480       Iface_DT        : Node_Id;
3481       Iface_DT_Ptr    : Node_Id;
3482       Name_DT_Ptr     : Name_Id;
3483       Nb_Prim         : Nat;
3484       OSD             : Entity_Id;
3485       Size_Expr_Node  : Node_Id;
3486       Tname           : Name_Id;
3487
3488    begin
3489       Result := New_List;
3490
3491       --  Generate a unique external name associated with the secondary
3492       --  dispatch table. This external name will be used to declare an
3493       --  access to this secondary dispatch table, value that will be used
3494       --  for the elaboration of Typ's objects and also for the elaboration
3495       --  of objects of any derivation of Typ that do not override any
3496       --  primitive operation of Typ.
3497
3498       Get_Secondary_DT_External_Name (Typ, Ancestor_Typ, Suffix_Index);
3499
3500       Tname        := Name_Find;
3501       Name_DT_Ptr  := New_External_Name (Tname, "P");
3502       Iface_DT     := Make_Defining_Identifier (Loc, Name_DT);
3503       Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);
3504
3505       --  Dispatch table and related entities are allocated statically
3506
3507       Set_Ekind (Iface_DT, E_Variable);
3508       Set_Is_Statically_Allocated (Iface_DT);
3509
3510       Set_Ekind (Iface_DT_Ptr, E_Variable);
3511       Set_Is_Statically_Allocated (Iface_DT_Ptr);
3512
3513       --  Generate code to create the storage for the Dispatch_Table object.
3514       --  If the number of primitives of Typ is 0 we reserve a dummy single
3515       --  entry for its DT because at run-time the pointer to this dummy entry
3516       --  will be used as the tag.
3517
3518       Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
3519
3520       if Nb_Prim = 0 then
3521          Empty_DT := True;
3522          Nb_Prim  := 1;
3523       end if;
3524
3525       --    DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
3526       --    for DT'Alignment use Address'Alignment
3527
3528       Size_Expr_Node :=
3529         Make_Op_Add (Loc,
3530           Left_Opnd  =>
3531             New_Reference_To (RTE (RE_DT_Prologue_Size), Loc),
3532           Right_Opnd =>
3533             Make_Op_Multiply (Loc,
3534               Left_Opnd  =>
3535                 New_Reference_To (RTE (RE_DT_Entry_Size), Loc),
3536               Right_Opnd =>
3537                 Make_Integer_Literal (Loc, Nb_Prim)));
3538
3539       Append_To (Result,
3540         Make_Object_Declaration (Loc,
3541           Defining_Identifier => Iface_DT,
3542           Aliased_Present     => True,
3543           Object_Definition   =>
3544             Make_Subtype_Indication (Loc,
3545               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
3546               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
3547                 Constraints => New_List (
3548                   Make_Range (Loc,
3549                     Low_Bound  => Make_Integer_Literal (Loc, 1),
3550                     High_Bound => Size_Expr_Node))))));
3551
3552       Append_To (Result,
3553         Make_Attribute_Definition_Clause (Loc,
3554           Name       => New_Reference_To (Iface_DT, Loc),
3555           Chars      => Name_Alignment,
3556           Expression =>
3557             Make_Attribute_Reference (Loc,
3558               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
3559               Attribute_Name => Name_Alignment)));
3560
3561       --  Generate code to create the pointer to the dispatch table
3562
3563       --    Iface_DT_Ptr : Tag := Tag!(DT'Address);
3564
3565       --  According to the C++ ABI, the base of the vtable is located
3566       --  after the following prologue: Offset_To_Top, and Typeinfo_Ptr.
3567       --  Hence, move the pointer down to the real base of the vtable.
3568
3569       Append_To (Result,
3570         Make_Object_Declaration (Loc,
3571           Defining_Identifier => Iface_DT_Ptr,
3572           Constant_Present    => True,
3573           Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
3574           Expression          =>
3575             Unchecked_Convert_To (Generalized_Tag,
3576               Make_Op_Add (Loc,
3577                 Left_Opnd =>
3578                   Unchecked_Convert_To (RTE (RE_Storage_Offset),
3579                     Make_Attribute_Reference (Loc,
3580                       Prefix         => New_Reference_To (Iface_DT, Loc),
3581                       Attribute_Name => Name_Address)),
3582                 Right_Opnd =>
3583                   New_Reference_To (RTE (RE_DT_Prologue_Size), Loc)))));
3584
3585       --  Note: Offset_To_Top will be initialized by the init subprogram
3586
3587       --  Set Access_Disp_Table field to be the dispatch table pointer
3588
3589       if not (Present (Acc_Disp_Tables)) then
3590          Acc_Disp_Tables := New_Elmt_List;
3591       end if;
3592
3593       Append_Elmt (Iface_DT_Ptr, Acc_Disp_Tables);
3594
3595       --  Step 1: Generate an Object Specific Data (OSD) table
3596
3597       OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
3598
3599       --  Nothing to do if configurable run time does not support the
3600       --  Object_Specific_Data entity.
3601
3602       if not RTE_Available (RE_Object_Specific_Data) then
3603          Error_Msg_CRT ("abstract interface types", Typ);
3604          return;
3605       end if;
3606
3607       --  Generate:
3608       --    OSD : Ada.Tags.Object_Specific_Data (Nb_Prims);
3609       --  where the constraint is used to allocate space for the
3610       --  non-predefined primitive operations only.
3611
3612       Append_To (Result,
3613         Make_Object_Declaration (Loc,
3614           Defining_Identifier => OSD,
3615           Object_Definition   =>
3616             Make_Subtype_Indication (Loc,
3617               Subtype_Mark => New_Reference_To (
3618                 RTE (RE_Object_Specific_Data), Loc),
3619               Constraint =>
3620                 Make_Index_Or_Discriminant_Constraint (Loc,
3621                   Constraints => New_List (
3622                     Make_Integer_Literal (Loc, Nb_Prim))))));
3623
3624       Append_To (Result,
3625         Make_DT_Access_Action (Typ,
3626           Action => Set_Signature,
3627           Args   => New_List (
3628             Unchecked_Convert_To (RTE (RE_Tag),
3629               New_Reference_To (Iface_DT_Ptr, Loc)),
3630             New_Reference_To (RTE (RE_Secondary_DT), Loc))));
3631
3632       --  Generate:
3633       --    Ada.Tags.Set_OSD (Iface_DT_Ptr, OSD);
3634
3635       Append_To (Result,
3636         Make_DT_Access_Action (Typ,
3637           Action => Set_OSD,
3638           Args   => New_List (
3639             Unchecked_Convert_To (RTE (RE_Tag),
3640               New_Reference_To (Iface_DT_Ptr, Loc)),
3641             Make_Attribute_Reference (Loc,
3642               Prefix         => New_Reference_To (OSD, Loc),
3643               Attribute_Name => Name_Address))));
3644
3645       if Ada_Version >= Ada_05
3646         and then not Is_Interface (Typ)
3647         and then not Is_Abstract_Type (Typ)
3648         and then not Is_Controlled (Typ)
3649         and then RTE_Available (RE_Set_Tagged_Kind)
3650         and then not Restriction_Active (No_Dispatching_Calls)
3651       then
3652          --  Generate:
3653          --    Set_Tagged_Kind (Iface'Tag, Tagged_Kind (Iface));
3654
3655          Append_To (Result,
3656            Make_DT_Access_Action (Typ,
3657              Action => Set_Tagged_Kind,
3658              Args   => New_List (
3659                Unchecked_Convert_To (RTE (RE_Tag),              -- DTptr
3660                  New_Reference_To (Iface_DT_Ptr, Loc)),
3661                Tagged_Kind (Typ))));                            -- Value
3662
3663          if not Empty_DT
3664            and then Is_Concurrent_Record_Type (Typ)
3665            and then Has_Abstract_Interfaces (Typ)
3666          then
3667             declare
3668                Prim       : Entity_Id;
3669                Prim_Alias : Entity_Id;
3670                Prim_Elmt  : Elmt_Id;
3671
3672             begin
3673                --  Step 2: Populate the OSD table
3674
3675                Prim_Alias := Empty;
3676                Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
3677                while Present (Prim_Elmt) loop
3678                   Prim := Node (Prim_Elmt);
3679
3680                   if Present (Abstract_Interface_Alias (Prim))
3681                     and then Find_Dispatching_Type
3682                                (Abstract_Interface_Alias (Prim)) = Iface
3683                   then
3684                      Prim_Alias := Abstract_Interface_Alias (Prim);
3685
3686                      --  Generate:
3687                      --    Ada.Tags.Set_Offset_Index (Tag (Iface_DT_Ptr),
3688                      --      Secondary_DT_Pos, Primary_DT_pos);
3689
3690                      Append_To (Result,
3691                        Make_DT_Access_Action (Iface,
3692                          Action => Set_Offset_Index,
3693                          Args   => New_List (
3694                            Unchecked_Convert_To (RTE (RE_Tag),
3695                              New_Reference_To (Iface_DT_Ptr, Loc)),
3696                            Make_Integer_Literal (Loc,
3697                              DT_Position (Prim_Alias)),
3698                            Make_Integer_Literal (Loc,
3699                              DT_Position (Alias (Prim))))));
3700                   end if;
3701
3702                   Next_Elmt (Prim_Elmt);
3703                end loop;
3704             end;
3705          end if;
3706       end if;
3707    end Make_Secondary_DT;
3708
3709    -------------------------------------
3710    -- Make_Select_Specific_Data_Table --
3711    -------------------------------------
3712
3713    function Make_Select_Specific_Data_Table
3714      (Typ : Entity_Id) return List_Id
3715    is
3716       Assignments : constant List_Id    := New_List;
3717       Loc         : constant Source_Ptr := Sloc (Typ);
3718
3719       Conc_Typ  : Entity_Id;
3720       Decls     : List_Id;
3721       DT_Ptr    : Entity_Id;
3722       Prim      : Entity_Id;
3723       Prim_Als  : Entity_Id;
3724       Prim_Elmt : Elmt_Id;
3725       Prim_Pos  : Uint;
3726       Nb_Prim   : Nat := 0;
3727
3728       type Examined_Array is array (Int range <>) of Boolean;
3729
3730       function Find_Entry_Index (E : Entity_Id) return Uint;
3731       --  Given an entry, find its index in the visible declarations of the
3732       --  corresponding concurrent type of Typ.
3733
3734       ----------------------
3735       -- Find_Entry_Index --
3736       ----------------------
3737
3738       function Find_Entry_Index (E : Entity_Id) return Uint is
3739          Index     : Uint := Uint_1;
3740          Subp_Decl : Entity_Id;
3741
3742       begin
3743          if Present (Decls)
3744            and then not Is_Empty_List (Decls)
3745          then
3746             Subp_Decl := First (Decls);
3747             while Present (Subp_Decl) loop
3748                if Nkind (Subp_Decl) = N_Entry_Declaration then
3749                   if Defining_Identifier (Subp_Decl) = E then
3750                      return Index;
3751                   end if;
3752
3753                   Index := Index + 1;
3754                end if;
3755
3756                Next (Subp_Decl);
3757             end loop;
3758          end if;
3759
3760          return Uint_0;
3761       end Find_Entry_Index;
3762
3763    --  Start of processing for Make_Select_Specific_Data_Table
3764
3765    begin
3766       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3767
3768       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
3769
3770       if Present (Corresponding_Concurrent_Type (Typ)) then
3771          Conc_Typ := Corresponding_Concurrent_Type (Typ);
3772
3773          if Ekind (Conc_Typ) = E_Protected_Type then
3774             Decls := Visible_Declarations (Protected_Definition (
3775                        Parent (Conc_Typ)));
3776          else
3777             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
3778             Decls := Visible_Declarations (Task_Definition (
3779                        Parent (Conc_Typ)));
3780          end if;
3781       end if;
3782
3783       --  Count the non-predefined primitive operations
3784
3785       Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3786       while Present (Prim_Elmt) loop
3787          Prim := Node (Prim_Elmt);
3788
3789          if not (Is_Predefined_Dispatching_Operation (Prim)
3790                    or else Is_Predefined_Dispatching_Alias (Prim))
3791          then
3792             Nb_Prim := Nb_Prim + 1;
3793          end if;
3794
3795          Next_Elmt (Prim_Elmt);
3796       end loop;
3797
3798       declare
3799          Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
3800
3801       begin
3802          Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3803          while Present (Prim_Elmt) loop
3804             Prim := Node (Prim_Elmt);
3805
3806             --  Look for primitive overriding an abstract interface subprogram
3807
3808             if Present (Abstract_Interface_Alias (Prim))
3809               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
3810             then
3811                Prim_Pos := DT_Position (Alias (Prim));
3812                pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
3813                Examined (UI_To_Int (Prim_Pos)) := True;
3814
3815                --  Set the primitive operation kind regardless of subprogram
3816                --  type. Generate:
3817                --    Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
3818
3819                Append_To (Assignments,
3820                  Make_DT_Access_Action (Typ,
3821                    Action => Set_Prim_Op_Kind,
3822                    Args => New_List (
3823                              New_Reference_To (DT_Ptr, Loc),
3824                              Make_Integer_Literal (Loc, Prim_Pos),
3825                              Prim_Op_Kind (Alias (Prim), Typ))));
3826
3827                --  Retrieve the root of the alias chain
3828
3829                Prim_Als := Prim;
3830                while Present (Alias (Prim_Als)) loop
3831                   Prim_Als := Alias (Prim_Als);
3832                end loop;
3833
3834                --  In the case of an entry wrapper, set the entry index
3835
3836                if Ekind (Prim) = E_Procedure
3837                  and then Is_Primitive_Wrapper (Prim_Als)
3838                  and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
3839                then
3840                   --  Generate:
3841                   --    Ada.Tags.Set_Entry_Index
3842                   --      (DT_Ptr, <position>, <index>);
3843
3844                   Append_To (Assignments,
3845                     Make_DT_Access_Action (Typ,
3846                       Action => Set_Entry_Index,
3847                       Args => New_List (
3848                                 New_Reference_To (DT_Ptr, Loc),
3849                                 Make_Integer_Literal (Loc, Prim_Pos),
3850                                 Make_Integer_Literal (Loc,
3851                                   Find_Entry_Index
3852                                     (Wrapped_Entity (Prim_Als))))));
3853                end if;
3854             end if;
3855
3856             Next_Elmt (Prim_Elmt);
3857          end loop;
3858       end;
3859
3860       return Assignments;
3861    end Make_Select_Specific_Data_Table;
3862
3863    -----------------------------------
3864    -- Original_View_In_Visible_Part --
3865    -----------------------------------
3866
3867    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
3868       Scop : constant Entity_Id := Scope (Typ);
3869
3870    begin
3871       --  The scope must be a package
3872
3873       if Ekind (Scop) /= E_Package
3874         and then Ekind (Scop) /= E_Generic_Package
3875       then
3876          return False;
3877       end if;
3878
3879       --  A type with a private declaration has a private view declared in
3880       --  the visible part.
3881
3882       if Has_Private_Declaration (Typ) then
3883          return True;
3884       end if;
3885
3886       return List_Containing (Parent (Typ)) =
3887         Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
3888    end Original_View_In_Visible_Part;
3889
3890    ------------------
3891    -- Prim_Op_Kind --
3892    ------------------
3893
3894    function Prim_Op_Kind
3895      (Prim : Entity_Id;
3896       Typ  : Entity_Id) return Node_Id
3897    is
3898       Full_Typ : Entity_Id := Typ;
3899       Loc      : constant Source_Ptr := Sloc (Prim);
3900       Prim_Op  : Entity_Id;
3901
3902    begin
3903       --  Retrieve the original primitive operation
3904
3905       Prim_Op := Prim;
3906       while Present (Alias (Prim_Op)) loop
3907          Prim_Op := Alias (Prim_Op);
3908       end loop;
3909
3910       if Ekind (Typ) = E_Record_Type
3911         and then Present (Corresponding_Concurrent_Type (Typ))
3912       then
3913          Full_Typ := Corresponding_Concurrent_Type (Typ);
3914       end if;
3915
3916       if Ekind (Prim_Op) = E_Function then
3917
3918          --  Protected function
3919
3920          if Ekind (Full_Typ) = E_Protected_Type then
3921             return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
3922
3923          --  Task function
3924
3925          elsif Ekind (Full_Typ) = E_Task_Type then
3926             return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
3927
3928          --  Regular function
3929
3930          else
3931             return New_Reference_To (RTE (RE_POK_Function), Loc);
3932          end if;
3933
3934       else
3935          pragma Assert (Ekind (Prim_Op) = E_Procedure);
3936
3937          if Ekind (Full_Typ) = E_Protected_Type then
3938
3939             --  Protected entry
3940
3941             if Is_Primitive_Wrapper (Prim_Op)
3942               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
3943             then
3944                return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
3945
3946             --  Protected procedure
3947
3948             else
3949                return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
3950             end if;
3951
3952          elsif Ekind (Full_Typ) = E_Task_Type then
3953
3954             --  Task entry
3955
3956             if Is_Primitive_Wrapper (Prim_Op)
3957               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
3958             then
3959                return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
3960
3961             --  Task "procedure". These are the internally Expander-generated
3962             --  procedures (task body for instance).
3963
3964             else
3965                return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
3966             end if;
3967
3968          --  Regular procedure
3969
3970          else
3971             return New_Reference_To (RTE (RE_POK_Procedure), Loc);
3972          end if;
3973       end if;
3974    end Prim_Op_Kind;
3975
3976    -------------------------
3977    -- Set_All_DT_Position --
3978    -------------------------
3979
3980    procedure Set_All_DT_Position (Typ : Entity_Id) is
3981
3982       procedure Validate_Position (Prim : Entity_Id);
3983       --  Check that the position assignated to Prim is completely safe
3984       --  (it has not been assigned to a previously defined primitive
3985       --   operation of Typ)
3986
3987       -----------------------
3988       -- Validate_Position --
3989       -----------------------
3990
3991       procedure Validate_Position (Prim : Entity_Id) is
3992          Op_Elmt : Elmt_Id;
3993          Op      : Entity_Id;
3994
3995       begin
3996          --  Aliased primitives are safe
3997
3998          if Present (Alias (Prim)) then
3999             return;
4000          end if;
4001
4002          Op_Elmt := First_Elmt (Primitive_Operations (Typ));
4003          while Present (Op_Elmt) loop
4004             Op := Node (Op_Elmt);
4005
4006             --  No need to check against itself
4007
4008             if Op = Prim then
4009                null;
4010
4011             --  Primitive operations covering abstract interfaces are
4012             --  allocated later
4013
4014             elsif Present (Abstract_Interface_Alias (Op)) then
4015                null;
4016
4017             --  Predefined dispatching operations are completely safe. They
4018             --  are allocated at fixed positions in a separate table.
4019
4020             elsif Is_Predefined_Dispatching_Operation (Op)
4021                or else Is_Predefined_Dispatching_Alias (Op)
4022             then
4023                null;
4024
4025             --  Aliased subprograms are safe
4026
4027             elsif Present (Alias (Op)) then
4028                null;
4029
4030             elsif DT_Position (Op) = DT_Position (Prim)
4031                and then not Is_Predefined_Dispatching_Operation (Op)
4032                and then not Is_Predefined_Dispatching_Operation (Prim)
4033                and then not Is_Predefined_Dispatching_Alias (Op)
4034                and then not Is_Predefined_Dispatching_Alias (Prim)
4035             then
4036
4037                --  Handle aliased subprograms
4038
4039                declare
4040                   Op_1 : Entity_Id;
4041                   Op_2 : Entity_Id;
4042
4043                begin
4044                   Op_1 := Op;
4045                   loop
4046                      if Present (Overridden_Operation (Op_1)) then
4047                         Op_1 := Overridden_Operation (Op_1);
4048                      elsif Present (Alias (Op_1)) then
4049                         Op_1 := Alias (Op_1);
4050                      else
4051                         exit;
4052                      end if;
4053                   end loop;
4054
4055                   Op_2 := Prim;
4056                   loop
4057                      if Present (Overridden_Operation (Op_2)) then
4058                         Op_2 := Overridden_Operation (Op_2);
4059                      elsif Present (Alias (Op_2)) then
4060                         Op_2 := Alias (Op_2);
4061                      else
4062                         exit;
4063                      end if;
4064                   end loop;
4065
4066                   if Op_1 /= Op_2 then
4067                      raise Program_Error;
4068                   end if;
4069                end;
4070             end if;
4071
4072             Next_Elmt (Op_Elmt);
4073          end loop;
4074       end Validate_Position;
4075
4076       --  Local variables
4077
4078       Parent_Typ : constant Entity_Id := Etype (Typ);
4079       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
4080       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
4081
4082       Adjusted   : Boolean := False;
4083       Finalized  : Boolean := False;
4084
4085       Count_Prim : Nat;
4086       DT_Length  : Nat;
4087       Nb_Prim    : Nat;
4088       Prim       : Entity_Id;
4089       Prim_Elmt  : Elmt_Id;
4090
4091    --  Start of processing for Set_All_DT_Position
4092
4093    begin
4094       --  Set the DT_Position for each primitive operation. Perform some
4095       --  sanity checks to avoid to build completely inconsistant dispatch
4096       --  tables.
4097
4098       --  First stage: Set the DTC entity of all the primitive operations
4099       --  This is required to properly read the DT_Position attribute in
4100       --  the latter stages.
4101
4102       Prim_Elmt  := First_Prim;
4103       Count_Prim := 0;
4104       while Present (Prim_Elmt) loop
4105          Prim := Node (Prim_Elmt);
4106
4107          --  Predefined primitives have a separate dispatch table
4108
4109          if not (Is_Predefined_Dispatching_Operation (Prim)
4110                    or else Is_Predefined_Dispatching_Alias (Prim))
4111          then
4112             Count_Prim := Count_Prim + 1;
4113          end if;
4114
4115          --  Ada 2005 (AI-251)
4116
4117          if Present (Abstract_Interface_Alias (Prim))
4118            and then Is_Interface
4119                       (Find_Dispatching_Type
4120                         (Abstract_Interface_Alias (Prim)))
4121          then
4122             Set_DTC_Entity (Prim,
4123                Find_Interface_Tag
4124                  (T => Typ,
4125                   Iface => Find_Dispatching_Type
4126                             (Abstract_Interface_Alias (Prim))));
4127          else
4128             Set_DTC_Entity (Prim, The_Tag);
4129          end if;
4130
4131          --  Clear any previous value of the DT_Position attribute. In this
4132          --  way we ensure that the final position of all the primitives is
4133          --  stablished by the following stages of this algorithm.
4134
4135          Set_DT_Position (Prim, No_Uint);
4136
4137          Next_Elmt (Prim_Elmt);
4138       end loop;
4139
4140       declare
4141          Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
4142                         := (others => False);
4143          E : Entity_Id;
4144
4145          procedure Set_Fixed_Prim (Pos : Nat);
4146          --  Sets to true an element of the Fixed_Prim table to indicate
4147          --  that this entry of the dispatch table of Typ is occupied.
4148
4149          --------------------
4150          -- Set_Fixed_Prim --
4151          --------------------
4152
4153          procedure Set_Fixed_Prim (Pos : Nat) is
4154          begin
4155             pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
4156             Fixed_Prim (Pos) := True;
4157          exception
4158             when Constraint_Error =>
4159                raise Program_Error;
4160          end Set_Fixed_Prim;
4161
4162       begin
4163          --  Second stage: Register fixed entries
4164
4165          Nb_Prim   := 0;
4166          Prim_Elmt := First_Prim;
4167          while Present (Prim_Elmt) loop
4168             Prim := Node (Prim_Elmt);
4169
4170             --  Predefined primitives have a separate table and all its
4171             --  entries are at predefined fixed positions.
4172
4173             if Is_Predefined_Dispatching_Operation (Prim) then
4174                Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
4175
4176             elsif Is_Predefined_Dispatching_Alias (Prim) then
4177                E := Alias (Prim);
4178                while Present (Alias (E)) loop
4179                   E := Alias (E);
4180                end loop;
4181
4182                Set_DT_Position (Prim, Default_Prim_Op_Position (E));
4183
4184             --  Overriding primitives of ancestor abstract interfaces
4185
4186             elsif Present (Abstract_Interface_Alias (Prim))
4187               and then Is_Parent
4188                          (Find_Dispatching_Type
4189                            (Abstract_Interface_Alias (Prim)),
4190                           Typ)
4191             then
4192                pragma Assert (DT_Position (Prim) = No_Uint
4193                  and then Present (DTC_Entity
4194                                     (Abstract_Interface_Alias (Prim))));
4195
4196                E := Abstract_Interface_Alias (Prim);
4197                Set_DT_Position (Prim, DT_Position (E));
4198
4199                pragma Assert
4200                  (DT_Position (Alias (Prim)) = No_Uint
4201                     or else DT_Position (Alias (Prim)) = DT_Position (E));
4202                Set_DT_Position (Alias (Prim), DT_Position (E));
4203                Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
4204
4205             --  Overriding primitives must use the same entry as the
4206             --  overriden primitive
4207
4208             elsif not Present (Abstract_Interface_Alias (Prim))
4209               and then Present (Alias (Prim))
4210               and then Find_Dispatching_Type (Alias (Prim)) /= Typ
4211               and then Is_Parent
4212                          (Find_Dispatching_Type (Alias (Prim)), Typ)
4213               and then Present (DTC_Entity (Alias (Prim)))
4214             then
4215                E := Alias (Prim);
4216                Set_DT_Position (Prim, DT_Position (E));
4217
4218                if not Is_Predefined_Dispatching_Alias (E) then
4219                   Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
4220                end if;
4221             end if;
4222
4223             Next_Elmt (Prim_Elmt);
4224          end loop;
4225
4226          --  Third stage: Fix the position of all the new primitives
4227          --  Entries associated with primitives covering interfaces
4228          --  are handled in a latter round.
4229
4230          Prim_Elmt := First_Prim;
4231          while Present (Prim_Elmt) loop
4232             Prim := Node (Prim_Elmt);
4233
4234             --  Skip primitives previously set entries
4235
4236             if DT_Position (Prim) /= No_Uint then
4237                null;
4238
4239             --  Primitives covering interface primitives are handled later
4240
4241             elsif Present (Abstract_Interface_Alias (Prim)) then
4242                null;
4243
4244             else
4245                --  Take the next available position in the DT
4246
4247                loop
4248                   Nb_Prim := Nb_Prim + 1;
4249                   pragma Assert (Nb_Prim <= Count_Prim);
4250                   exit when not Fixed_Prim (Nb_Prim);
4251                end loop;
4252
4253                Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
4254                Set_Fixed_Prim (Nb_Prim);
4255             end if;
4256
4257             Next_Elmt (Prim_Elmt);
4258          end loop;
4259       end;
4260
4261       --  Fourth stage: Complete the decoration of primitives covering
4262       --  interfaces (that is, propagate the DT_Position attribute
4263       --  from the aliased primitive)
4264
4265       Prim_Elmt := First_Prim;
4266       while Present (Prim_Elmt) loop
4267          Prim := Node (Prim_Elmt);
4268
4269          if DT_Position (Prim) = No_Uint
4270            and then Present (Abstract_Interface_Alias (Prim))
4271          then
4272             pragma Assert (Present (Alias (Prim))
4273               and then Find_Dispatching_Type (Alias (Prim)) = Typ);
4274
4275             --  Check if this entry will be placed in the primary DT
4276
4277             if Is_Parent (Find_Dispatching_Type
4278                            (Abstract_Interface_Alias (Prim)),
4279                           Typ)
4280             then
4281                pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
4282                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
4283
4284             --  Otherwise it will be placed in the secondary DT
4285
4286             else
4287                pragma Assert
4288                  (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
4289                Set_DT_Position (Prim,
4290                  DT_Position (Abstract_Interface_Alias (Prim)));
4291             end if;
4292          end if;
4293
4294          Next_Elmt (Prim_Elmt);
4295       end loop;
4296
4297       --  Generate listing showing the contents of the dispatch tables.
4298       --  This action is done before some further static checks because
4299       --  in case of critical errors caused by a wrong dispatch table
4300       --  we need to see the contents of such table.
4301
4302       if Debug_Flag_ZZ then
4303          Write_DT (Typ);
4304       end if;
4305
4306       --  Final stage: Ensure that the table is correct plus some further
4307       --  verifications concerning the primitives.
4308
4309       Prim_Elmt := First_Prim;
4310       DT_Length := 0;
4311       while Present (Prim_Elmt) loop
4312          Prim := Node (Prim_Elmt);
4313
4314          --  At this point all the primitives MUST have a position
4315          --  in the dispatch table
4316
4317          if DT_Position (Prim) = No_Uint then
4318             raise Program_Error;
4319          end if;
4320
4321          --  Calculate real size of the dispatch table
4322
4323          if not (Is_Predefined_Dispatching_Operation (Prim)
4324                    or else Is_Predefined_Dispatching_Alias (Prim))
4325            and then UI_To_Int (DT_Position (Prim)) > DT_Length
4326          then
4327             DT_Length := UI_To_Int (DT_Position (Prim));
4328          end if;
4329
4330          --  Ensure that the asignated position to non-predefined
4331          --  dispatching operations in the dispatch table is correct.
4332
4333          if not (Is_Predefined_Dispatching_Operation (Prim)
4334                    or else Is_Predefined_Dispatching_Alias (Prim))
4335          then
4336             Validate_Position (Prim);
4337          end if;
4338
4339          if Chars (Prim) = Name_Finalize then
4340             Finalized := True;
4341          end if;
4342
4343          if Chars (Prim) = Name_Adjust then
4344             Adjusted := True;
4345          end if;
4346
4347          --  An abstract operation cannot be declared in the private part
4348          --  for a visible abstract type, because it could never be over-
4349          --  ridden. For explicit declarations this is checked at the
4350          --  point of declaration, but for inherited operations it must
4351          --  be done when building the dispatch table.
4352
4353          --  Ada 2005 (AI-251): Hidden entities associated with abstract
4354          --  interface primitives are not taken into account because the
4355          --  check is done with the aliased primitive.
4356
4357          if Is_Abstract_Type (Typ)
4358            and then Is_Abstract_Subprogram (Prim)
4359            and then Present (Alias (Prim))
4360            and then not Present (Abstract_Interface_Alias (Prim))
4361            and then Is_Derived_Type (Typ)
4362            and then In_Private_Part (Current_Scope)
4363            and then
4364              List_Containing (Parent (Prim)) =
4365                Private_Declarations
4366                 (Specification (Unit_Declaration_Node (Current_Scope)))
4367            and then Original_View_In_Visible_Part (Typ)
4368          then
4369             --  We exclude Input and Output stream operations because
4370             --  Limited_Controlled inherits useless Input and Output
4371             --  stream operations from Root_Controlled, which can
4372             --  never be overridden.
4373
4374             if not Is_TSS (Prim, TSS_Stream_Input)
4375                  and then
4376                not Is_TSS (Prim, TSS_Stream_Output)
4377             then
4378                Error_Msg_NE
4379                  ("abstract inherited private operation&" &
4380                   " must be overridden ('R'M 3.9.3(10))",
4381                  Parent (Typ), Prim);
4382             end if;
4383          end if;
4384
4385          Next_Elmt (Prim_Elmt);
4386       end loop;
4387
4388       --  Additional check
4389
4390       if Is_Controlled (Typ) then
4391          if not Finalized then
4392             Error_Msg_N
4393               ("controlled type has no explicit Finalize method?", Typ);
4394
4395          elsif not Adjusted then
4396             Error_Msg_N
4397               ("controlled type has no explicit Adjust method?", Typ);
4398          end if;
4399       end if;
4400
4401       --  Set the final size of the Dispatch Table
4402
4403       Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
4404
4405       --  The derived type must have at least as many components as its
4406       --  parent (for root types, the Etype points back to itself
4407       --  and the test should not fail)
4408
4409       --  This test fails compiling the partial view of a tagged type
4410       --  derived from an interface which defines the overriding subprogram
4411       --  in the private part. This needs further investigation???
4412
4413       if not Has_Private_Declaration (Typ) then
4414          pragma Assert (
4415            DT_Entry_Count (The_Tag) >=
4416            DT_Entry_Count (First_Tag_Component (Parent_Typ)));
4417          null;
4418       end if;
4419    end Set_All_DT_Position;
4420
4421    -----------------------------
4422    -- Set_Default_Constructor --
4423    -----------------------------
4424
4425    procedure Set_Default_Constructor (Typ : Entity_Id) is
4426       Loc   : Source_Ptr;
4427       Init  : Entity_Id;
4428       Param : Entity_Id;
4429       E     : Entity_Id;
4430
4431    begin
4432       --  Look for the default constructor entity. For now only the
4433       --  default constructor has the flag Is_Constructor.
4434
4435       E := Next_Entity (Typ);
4436       while Present (E)
4437         and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
4438       loop
4439          Next_Entity (E);
4440       end loop;
4441
4442       --  Create the init procedure
4443
4444       if Present (E) then
4445          Loc   := Sloc (E);
4446          Init  := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
4447          Param := Make_Defining_Identifier (Loc, Name_X);
4448
4449          Discard_Node (
4450            Make_Subprogram_Declaration (Loc,
4451              Make_Procedure_Specification (Loc,
4452                Defining_Unit_Name => Init,
4453                Parameter_Specifications => New_List (
4454                  Make_Parameter_Specification (Loc,
4455                    Defining_Identifier => Param,
4456                    Parameter_Type      => New_Reference_To (Typ, Loc))))));
4457
4458          Set_Init_Proc (Typ, Init);
4459          Set_Is_Imported    (Init);
4460          Set_Interface_Name (Init, Interface_Name (E));
4461          Set_Convention     (Init, Convention_C);
4462          Set_Is_Public      (Init);
4463          Set_Has_Completion (Init);
4464
4465       --  If there are no constructors, mark the type as abstract since we
4466       --  won't be able to declare objects of that type.
4467
4468       else
4469          Set_Is_Abstract_Type (Typ);
4470       end if;
4471    end Set_Default_Constructor;
4472
4473    -----------------
4474    -- Tagged_Kind --
4475    -----------------
4476
4477    function Tagged_Kind (T : Entity_Id) return Node_Id is
4478       Conc_Typ : Entity_Id;
4479       Loc      : constant Source_Ptr := Sloc (T);
4480
4481    begin
4482       pragma Assert
4483         (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
4484
4485       --  Abstract kinds
4486
4487       if Is_Abstract_Type (T) then
4488          if Is_Limited_Record (T) then
4489             return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
4490          else
4491             return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
4492          end if;
4493
4494       --  Concurrent kinds
4495
4496       elsif Is_Concurrent_Record_Type (T) then
4497          Conc_Typ := Corresponding_Concurrent_Type (T);
4498
4499          if Ekind (Conc_Typ) = E_Protected_Type then
4500             return New_Reference_To (RTE (RE_TK_Protected), Loc);
4501          else
4502             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
4503             return New_Reference_To (RTE (RE_TK_Task), Loc);
4504          end if;
4505
4506       --  Regular tagged kinds
4507
4508       else
4509          if Is_Limited_Record (T) then
4510             return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
4511          else
4512             return New_Reference_To (RTE (RE_TK_Tagged), Loc);
4513          end if;
4514       end if;
4515    end Tagged_Kind;
4516
4517    --------------
4518    -- Write_DT --
4519    --------------
4520
4521    procedure Write_DT (Typ : Entity_Id) is
4522       Elmt : Elmt_Id;
4523       Prim : Node_Id;
4524
4525    begin
4526       --  Protect this procedure against wrong usage. Required because it will
4527       --  be used directly from GDB
4528
4529       if not (Typ in First_Node_Id .. Last_Node_Id)
4530         or else not Is_Tagged_Type (Typ)
4531       then
4532          Write_Str ("wrong usage: Write_DT must be used with tagged types");
4533          Write_Eol;
4534          return;
4535       end if;
4536
4537       Write_Int (Int (Typ));
4538       Write_Str (": ");
4539       Write_Name (Chars (Typ));
4540
4541       if Is_Interface (Typ) then
4542          Write_Str (" is interface");
4543       end if;
4544
4545       Write_Eol;
4546
4547       Elmt := First_Elmt (Primitive_Operations (Typ));
4548       while Present (Elmt) loop
4549          Prim := Node (Elmt);
4550          Write_Str  (" - ");
4551
4552          --  Indicate if this primitive will be allocated in the primary
4553          --  dispatch table or in a secondary dispatch table associated
4554          --  with an abstract interface type
4555
4556          if Present (DTC_Entity (Prim)) then
4557             if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
4558                Write_Str ("[P] ");
4559             else
4560                Write_Str ("[s] ");
4561             end if;
4562          end if;
4563
4564          --  Output the node of this primitive operation and its name
4565
4566          Write_Int  (Int (Prim));
4567          Write_Str  (": ");
4568
4569          if Is_Predefined_Dispatching_Operation (Prim) then
4570             Write_Str ("(predefined) ");
4571          end if;
4572
4573          Write_Name (Chars (Prim));
4574
4575          --  Indicate if this primitive has an aliased primitive
4576
4577          if Present (Alias (Prim)) then
4578             Write_Str (" (alias = ");
4579             Write_Int (Int (Alias (Prim)));
4580
4581             --  If the DTC_Entity attribute is already set we can also output
4582             --  the name of the interface covered by this primitive (if any)
4583
4584             if Present (DTC_Entity (Alias (Prim)))
4585               and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
4586             then
4587                Write_Str  (" from interface ");
4588                Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
4589             end if;
4590
4591             if Present (Abstract_Interface_Alias (Prim)) then
4592                Write_Str  (", AI_Alias of ");
4593                Write_Name (Chars (Scope (DTC_Entity
4594                                           (Abstract_Interface_Alias (Prim)))));
4595                Write_Char (':');
4596                Write_Int  (Int (Abstract_Interface_Alias (Prim)));
4597             end if;
4598
4599             Write_Str (")");
4600          end if;
4601
4602          --  Display the final position of this primitive in its associated
4603          --  (primary or secondary) dispatch table
4604
4605          if Present (DTC_Entity (Prim))
4606            and then DT_Position (Prim) /= No_Uint
4607          then
4608             Write_Str (" at #");
4609             Write_Int (UI_To_Int (DT_Position (Prim)));
4610          end if;
4611
4612          if Is_Abstract_Subprogram (Prim) then
4613             Write_Str (" is abstract;");
4614
4615          --  Check if this is a null primitive
4616
4617          elsif Comes_From_Source (Prim)
4618            and then Ekind (Prim) = E_Procedure
4619            and then Null_Present (Parent (Prim))
4620          then
4621             Write_Str (" is null;");
4622          end if;
4623
4624          Write_Eol;
4625
4626          Next_Elmt (Elmt);
4627       end loop;
4628    end Write_DT;
4629
4630 end Exp_Disp;