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