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