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-2013, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Atag; use Exp_Atag;
  33 with Exp_Ch6;  use Exp_Ch6;
  34 with Exp_CG;   use Exp_CG;
  35 with Exp_Dbug; use Exp_Dbug;
  36 with Exp_Tss;  use Exp_Tss;
  37 with Exp_Util; use Exp_Util;
  38 with Freeze;   use Freeze;
  39 with Itypes;   use Itypes;
  40 with Layout;   use Layout;
  41 with Nlists;   use Nlists;
  42 with Nmake;    use Nmake;
  43 with Namet;    use Namet;
  44 with Opt;      use Opt;
  45 with Output;   use Output;
  46 with Restrict; use Restrict;
  47 with Rident;   use Rident;
  48 with Rtsfind;  use Rtsfind;
  49 with Sem;      use Sem;
  50 with Sem_Aux;  use Sem_Aux;
  51 with Sem_Ch6;  use Sem_Ch6;
  52 with Sem_Ch7;  use Sem_Ch7;
  53 with Sem_Ch8;  use Sem_Ch8;
  54 with Sem_Disp; use Sem_Disp;
  55 with Sem_Eval; use Sem_Eval;
  56 with Sem_Res;  use Sem_Res;
  57 with Sem_Type; use Sem_Type;
  58 with Sem_Util; use Sem_Util;
  59 with Sinfo;    use Sinfo;
  60 with Snames;   use Snames;
  61 with Stand;    use Stand;
  62 with Stringt;  use Stringt;
  63 with SCIL_LL;  use SCIL_LL;
  64 with Targparm; use Targparm;
  65 with Tbuild;   use Tbuild;
  66 with Uintp;    use Uintp;
  67
  68 package body Exp_Disp is
  69
  70    -----------------------
  71    -- Local Subprograms --
  72    -----------------------
  73
  74    function Default_Prim_Op_Position (E : Entity_Id) return Uint;
  75    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
  76    --  of the default primitive operations.
  77
  78    function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
  79    --  Find specific type of a class-wide type, and handle the case of an
  80    --  incomplete type coming either from a limited_with clause or from an
  81    --  incomplete type declaration. Shouldn't this be in Sem_Util? It seems
  82    --  like a general purpose semantic routine ???
  83
  84    function Has_DT (Typ : Entity_Id) return Boolean;
  85    pragma Inline (Has_DT);
  86    --  Returns true if we generate a dispatch table for tagged type Typ
  87
  88    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
  89    --  Returns true if Prim is not a predefined dispatching primitive but it is
  90    --  an alias of a predefined dispatching primitive (i.e. through a renaming)
  91
  92    function New_Value (From : Node_Id) return Node_Id;
  93    --  From is the original Expression. New_Value is equivalent to a call
  94    --  to Duplicate_Subexpr with an explicit dereference when From is an
  95    --  access parameter.
  96
  97    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
  98    --  Check if the type has a private view or if the public view appears
  99    --  in the visible part of a package spec.
 100
 101    function Prim_Op_Kind
 102      (Prim : Entity_Id;
 103       Typ  : Entity_Id) return Node_Id;
 104    --  Ada 2005 (AI-345): Determine the primitive operation kind of Prim
 105    --  according to its type Typ. Return a reference to an RE_Prim_Op_Kind
 106    --  enumeration value.
 107
 108    function Tagged_Kind (T : Entity_Id) return Node_Id;
 109    --  Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
 110    --  to an RE_Tagged_Kind enumeration value.
 111
 112    ----------------------
 113    -- Apply_Tag_Checks --
 114    ----------------------
 115
 116    procedure Apply_Tag_Checks (Call_Node : Node_Id) is
 117       Loc        : constant Source_Ptr := Sloc (Call_Node);
 118       Ctrl_Arg   : constant Node_Id   := Controlling_Argument (Call_Node);
 119       Ctrl_Typ   : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
 120       Param_List : constant List_Id   := Parameter_Associations (Call_Node);
 121
 122       Subp            : Entity_Id;
 123       CW_Typ          : Entity_Id;
 124       Param           : Node_Id;
 125       Typ             : Entity_Id;
 126       Eq_Prim_Op      : Entity_Id := Empty;
 127
 128    begin
 129       if No_Run_Time_Mode then
 130          Error_Msg_CRT ("tagged types", Call_Node);
 131          return;
 132       end if;
 133
 134       --  Apply_Tag_Checks is called directly from the semantics, so we need
 135       --  a check to see whether expansion is active before proceeding. In
 136       --  addition, there is no need to expand the call when compiling under
 137       --  restriction No_Dispatching_Calls; the semantic analyzer has
 138       --  previously notified the violation of this restriction.
 139
 140       if not Expander_Active
 141         or else Restriction_Active (No_Dispatching_Calls)
 142       then
 143          return;
 144       end if;
 145
 146       --  Set subprogram. If this is an inherited operation that was
 147       --  overridden, the body that is being called is its alias.
 148
 149       Subp := Entity (Name (Call_Node));
 150
 151       if Present (Alias (Subp))
 152         and then Is_Inherited_Operation (Subp)
 153         and then No (DTC_Entity (Subp))
 154       then
 155          Subp := Alias (Subp);
 156       end if;
 157
 158       --  Definition of the class-wide type and the tagged type
 159
 160       --  If the controlling argument is itself a tag rather than a tagged
 161       --  object, then use the class-wide type associated with the subprogram's
 162       --  controlling type. This case can occur when a call to an inherited
 163       --  primitive has an actual that originated from a default parameter
 164       --  given by a tag-indeterminate call and when there is no other
 165       --  controlling argument providing the tag (AI-239 requires dispatching).
 166       --  This capability of dispatching directly by tag is also needed by the
 167       --  implementation of AI-260 (for the generic dispatching constructors).
 168
 169       if Ctrl_Typ = RTE (RE_Tag)
 170         or else (RTE_Available (RE_Interface_Tag)
 171                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
 172       then
 173          CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
 174
 175       --  Class_Wide_Type is applied to the expressions used to initialize
 176       --  CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
 177       --  there are cases where the controlling type is resolved to a specific
 178       --  type (such as for designated types of arguments such as CW'Access).
 179
 180       elsif Is_Access_Type (Ctrl_Typ) then
 181          CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
 182
 183       else
 184          CW_Typ := Class_Wide_Type (Ctrl_Typ);
 185       end if;
 186
 187       Typ := Find_Specific_Type (CW_Typ);
 188
 189       if not Is_Limited_Type (Typ) then
 190          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
 191       end if;
 192
 193       --  Dispatching call to C++ primitive
 194
 195       if Is_CPP_Class (Typ) then
 196          null;
 197
 198       --  Dispatching call to Ada primitive
 199
 200       elsif Present (Param_List) then
 201
 202          --  Generate the Tag checks when appropriate
 203
 204          Param := First_Actual (Call_Node);
 205          while Present (Param) loop
 206
 207             --  No tag check with itself
 208
 209             if Param = Ctrl_Arg then
 210                null;
 211
 212             --  No tag check for parameter whose type is neither tagged nor
 213             --  access to tagged (for access parameters)
 214
 215             elsif No (Find_Controlling_Arg (Param)) then
 216                null;
 217
 218             --  No tag check for function dispatching on result if the
 219             --  Tag given by the context is this one
 220
 221             elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
 222                null;
 223
 224             --  "=" is the only dispatching operation allowed to get
 225             --  operands with incompatible tags (it just returns false).
 226             --  We use Duplicate_Subexpr_Move_Checks instead of calling
 227             --  Relocate_Node because the value will be duplicated to
 228             --  check the tags.
 229
 230             elsif Subp = Eq_Prim_Op then
 231                null;
 232
 233             --  No check in presence of suppress flags
 234
 235             elsif Tag_Checks_Suppressed (Etype (Param))
 236               or else (Is_Access_Type (Etype (Param))
 237                          and then Tag_Checks_Suppressed
 238                                     (Designated_Type (Etype (Param))))
 239             then
 240                null;
 241
 242             --  Optimization: no tag checks if the parameters are identical
 243
 244             elsif Is_Entity_Name (Param)
 245               and then Is_Entity_Name (Ctrl_Arg)
 246               and then Entity (Param) = Entity (Ctrl_Arg)
 247             then
 248                null;
 249
 250             --  Now we need to generate the Tag check
 251
 252             else
 253                --  Generate code for tag equality check
 254                --  Perhaps should have Checks.Apply_Tag_Equality_Check???
 255
 256                Insert_Action (Ctrl_Arg,
 257                  Make_Implicit_If_Statement (Call_Node,
 258                    Condition =>
 259                      Make_Op_Ne (Loc,
 260                        Left_Opnd =>
 261                          Make_Selected_Component (Loc,
 262                            Prefix => New_Value (Ctrl_Arg),
 263                            Selector_Name =>
 264                              New_Reference_To
 265                                (First_Tag_Component (Typ), Loc)),
 266
 267                        Right_Opnd =>
 268                          Make_Selected_Component (Loc,
 269                            Prefix =>
 270                              Unchecked_Convert_To (Typ, New_Value (Param)),
 271                            Selector_Name =>
 272                              New_Reference_To
 273                                (First_Tag_Component (Typ), Loc))),
 274
 275                    Then_Statements =>
 276                      New_List (New_Constraint_Error (Loc))));
 277             end if;
 278
 279             Next_Actual (Param);
 280          end loop;
 281       end if;
 282    end Apply_Tag_Checks;
 283
 284    ------------------------
 285    -- Building_Static_DT --
 286    ------------------------
 287
 288    function Building_Static_DT (Typ : Entity_Id) return Boolean is
 289       Root_Typ : Entity_Id := Root_Type (Typ);
 290
 291    begin
 292       --  Handle private types
 293
 294       if Present (Full_View (Root_Typ)) then
 295          Root_Typ := Full_View (Root_Typ);
 296       end if;
 297
 298       return Static_Dispatch_Tables
 299         and then Is_Library_Level_Tagged_Type (Typ)
 300         and then VM_Target = No_VM
 301
 302          --  If the type is derived from a CPP class we cannot statically
 303          --  build the dispatch tables because we must inherit primitives
 304          --  from the CPP side.
 305
 306         and then not Is_CPP_Class (Root_Typ);
 307    end Building_Static_DT;
 308
 309    ----------------------------------
 310    -- Build_Static_Dispatch_Tables --
 311    ----------------------------------
 312
 313    procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
 314       Target_List : List_Id;
 315
 316       procedure Build_Dispatch_Tables (List : List_Id);
 317       --  Build the static dispatch table of tagged types found in the list of
 318       --  declarations. The generated nodes are added at the end of Target_List
 319
 320       procedure Build_Package_Dispatch_Tables (N : Node_Id);
 321       --  Build static dispatch tables associated with package declaration N
 322
 323       ---------------------------
 324       -- Build_Dispatch_Tables --
 325       ---------------------------
 326
 327       procedure Build_Dispatch_Tables (List : List_Id) is
 328          D : Node_Id;
 329
 330       begin
 331          D := First (List);
 332          while Present (D) loop
 333
 334             --  Handle nested packages and package bodies recursively. The
 335             --  generated code is placed on the Target_List established for
 336             --  the enclosing compilation unit.
 337
 338             if Nkind (D) = N_Package_Declaration then
 339                Build_Package_Dispatch_Tables (D);
 340
 341             elsif Nkind (D) = N_Package_Body then
 342                Build_Dispatch_Tables (Declarations (D));
 343
 344             elsif Nkind (D) = N_Package_Body_Stub
 345               and then Present (Library_Unit (D))
 346             then
 347                Build_Dispatch_Tables
 348                  (Declarations (Proper_Body (Unit (Library_Unit (D)))));
 349
 350             --  Handle full type declarations and derivations of library
 351             --  level tagged types
 352
 353             elsif Nkind_In (D, N_Full_Type_Declaration,
 354                                N_Derived_Type_Definition)
 355               and then Is_Library_Level_Tagged_Type (Defining_Entity (D))
 356               and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
 357               and then not Is_Private_Type (Defining_Entity (D))
 358             then
 359                --  We do not generate dispatch tables for the internal types
 360                --  created for a type extension with unknown discriminants
 361                --  The needed information is shared with the source type,
 362                --  See Expand_N_Record_Extension.
 363
 364                if Is_Underlying_Record_View (Defining_Entity (D))
 365                  or else
 366                   (not Comes_From_Source (Defining_Entity (D))
 367                      and then
 368                        Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
 369                      and then
 370                        not Comes_From_Source
 371                              (First_Subtype (Defining_Entity (D))))
 372                then
 373                   null;
 374                else
 375                   Insert_List_After_And_Analyze (Last (Target_List),
 376                     Make_DT (Defining_Entity (D)));
 377                end if;
 378
 379             --  Handle private types of library level tagged types. We must
 380             --  exchange the private and full-view to ensure the correct
 381             --  expansion. If the full view is a synchronized type ignore
 382             --  the type because the table will be built for the corresponding
 383             --  record type, that has its own declaration.
 384
 385             elsif (Nkind (D) = N_Private_Type_Declaration
 386                      or else Nkind (D) = N_Private_Extension_Declaration)
 387                and then Present (Full_View (Defining_Entity (D)))
 388             then
 389                declare
 390                   E1 : constant Entity_Id := Defining_Entity (D);
 391                   E2 : constant Entity_Id := Full_View (E1);
 392
 393                begin
 394                   if Is_Library_Level_Tagged_Type (E2)
 395                     and then Ekind (E2) /= E_Record_Subtype
 396                     and then not Is_Concurrent_Type (E2)
 397                   then
 398                      Exchange_Declarations (E1);
 399                      Insert_List_After_And_Analyze (Last (Target_List),
 400                        Make_DT (E1));
 401                      Exchange_Declarations (E2);
 402                   end if;
 403                end;
 404             end if;
 405
 406             Next (D);
 407          end loop;
 408       end Build_Dispatch_Tables;
 409
 410       -----------------------------------
 411       -- Build_Package_Dispatch_Tables --
 412       -----------------------------------
 413
 414       procedure Build_Package_Dispatch_Tables (N : Node_Id) is
 415          Spec       : constant Node_Id   := Specification (N);
 416          Id         : constant Entity_Id := Defining_Entity (N);
 417          Vis_Decls  : constant List_Id   := Visible_Declarations (Spec);
 418          Priv_Decls : constant List_Id   := Private_Declarations (Spec);
 419
 420       begin
 421          Push_Scope (Id);
 422
 423          if Present (Priv_Decls) then
 424             Build_Dispatch_Tables (Vis_Decls);
 425             Build_Dispatch_Tables (Priv_Decls);
 426
 427          elsif Present (Vis_Decls) then
 428             Build_Dispatch_Tables (Vis_Decls);
 429          end if;
 430
 431          Pop_Scope;
 432       end Build_Package_Dispatch_Tables;
 433
 434    --  Start of processing for Build_Static_Dispatch_Tables
 435
 436    begin
 437       if not Expander_Active
 438         or else not Tagged_Type_Expansion
 439       then
 440          return;
 441       end if;
 442
 443       if Nkind (N) = N_Package_Declaration then
 444          declare
 445             Spec       : constant Node_Id := Specification (N);
 446             Vis_Decls  : constant List_Id := Visible_Declarations (Spec);
 447             Priv_Decls : constant List_Id := Private_Declarations (Spec);
 448
 449          begin
 450             if Present (Priv_Decls)
 451               and then Is_Non_Empty_List (Priv_Decls)
 452             then
 453                Target_List := Priv_Decls;
 454
 455             elsif not Present (Vis_Decls) then
 456                Target_List := New_List;
 457                Set_Private_Declarations (Spec, Target_List);
 458             else
 459                Target_List := Vis_Decls;
 460             end if;
 461
 462             Build_Package_Dispatch_Tables (N);
 463          end;
 464
 465       else pragma Assert (Nkind (N) = N_Package_Body);
 466          Target_List := Declarations (N);
 467          Build_Dispatch_Tables (Target_List);
 468       end if;
 469    end Build_Static_Dispatch_Tables;
 470
 471    ------------------------------
 472    -- Convert_Tag_To_Interface --
 473    ------------------------------
 474
 475    function Convert_Tag_To_Interface
 476      (Typ  : Entity_Id;
 477       Expr : Node_Id) return Node_Id
 478    is
 479       Loc       : constant Source_Ptr := Sloc (Expr);
 480       Anon_Type : Entity_Id;
 481       Result    : Node_Id;
 482
 483    begin
 484       pragma Assert (Is_Class_Wide_Type (Typ)
 485         and then Is_Interface (Typ)
 486         and then
 487           ((Nkind (Expr) = N_Selected_Component
 488              and then Is_Tag (Entity (Selector_Name (Expr))))
 489            or else
 490            (Nkind (Expr) = N_Function_Call
 491              and then RTE_Available (RE_Displace)
 492              and then Entity (Name (Expr)) = RTE (RE_Displace))));
 493
 494       Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
 495       Set_Directly_Designated_Type (Anon_Type, Typ);
 496       Set_Etype (Anon_Type, Anon_Type);
 497       Set_Can_Never_Be_Null (Anon_Type);
 498
 499       --  Decorate the size and alignment attributes of the anonymous access
 500       --  type, as required by gigi.
 501
 502       Layout_Type (Anon_Type);
 503
 504       if Nkind (Expr) = N_Selected_Component
 505         and then Is_Tag (Entity (Selector_Name (Expr)))
 506       then
 507          Result :=
 508            Make_Explicit_Dereference (Loc,
 509              Unchecked_Convert_To (Anon_Type,
 510                Make_Attribute_Reference (Loc,
 511                  Prefix         => Expr,
 512                  Attribute_Name => Name_Address)));
 513       else
 514          Result :=
 515            Make_Explicit_Dereference (Loc,
 516              Unchecked_Convert_To (Anon_Type, Expr));
 517       end if;
 518
 519       return Result;
 520    end Convert_Tag_To_Interface;
 521
 522    -------------------
 523    -- CPP_Num_Prims --
 524    -------------------
 525
 526    function CPP_Num_Prims (Typ : Entity_Id) return Nat is
 527       CPP_Typ  : Entity_Id;
 528       Tag_Comp : Entity_Id;
 529
 530    begin
 531       if not Is_Tagged_Type (Typ)
 532         or else not Is_CPP_Class (Root_Type (Typ))
 533       then
 534          return 0;
 535
 536       else
 537          CPP_Typ  := Enclosing_CPP_Parent (Typ);
 538          Tag_Comp := First_Tag_Component (CPP_Typ);
 539
 540          --  If the number of primitives is already set in the tag component
 541          --  then use it
 542
 543          if Present (Tag_Comp)
 544            and then DT_Entry_Count (Tag_Comp) /= No_Uint
 545          then
 546             return UI_To_Int (DT_Entry_Count (Tag_Comp));
 547
 548          --  Otherwise, count the primitives of the enclosing CPP type
 549
 550          else
 551             declare
 552                Count : Nat := 0;
 553                Elmt  : Elmt_Id;
 554
 555             begin
 556                Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
 557                while Present (Elmt) loop
 558                   Count := Count + 1;
 559                   Next_Elmt (Elmt);
 560                end loop;
 561
 562                return Count;
 563             end;
 564          end if;
 565       end if;
 566    end CPP_Num_Prims;
 567
 568    ------------------------------
 569    -- Default_Prim_Op_Position --
 570    ------------------------------
 571
 572    function Default_Prim_Op_Position (E : Entity_Id) return Uint is
 573       TSS_Name : TSS_Name_Type;
 574
 575    begin
 576       Get_Name_String (Chars (E));
 577       TSS_Name :=
 578         TSS_Name_Type
 579           (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
 580
 581       if Chars (E) = Name_uSize then
 582          return Uint_1;
 583
 584       elsif TSS_Name = TSS_Stream_Read then
 585          return Uint_2;
 586
 587       elsif TSS_Name = TSS_Stream_Write then
 588          return Uint_3;
 589
 590       elsif TSS_Name = TSS_Stream_Input then
 591          return Uint_4;
 592
 593       elsif TSS_Name = TSS_Stream_Output then
 594          return Uint_5;
 595
 596       elsif Chars (E) = Name_Op_Eq then
 597          return Uint_6;
 598
 599       elsif Chars (E) = Name_uAssign then
 600          return Uint_7;
 601
 602       elsif TSS_Name = TSS_Deep_Adjust then
 603          return Uint_8;
 604
 605       elsif TSS_Name = TSS_Deep_Finalize then
 606          return Uint_9;
 607
 608       --  In VM targets unconditionally allow obtaining the position associated
 609       --  with predefined interface primitives since in these platforms any
 610       --  tagged type has these primitives.
 611
 612       elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
 613          if Chars (E) = Name_uDisp_Asynchronous_Select then
 614             return Uint_10;
 615
 616          elsif Chars (E) = Name_uDisp_Conditional_Select then
 617             return Uint_11;
 618
 619          elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
 620             return Uint_12;
 621
 622          elsif Chars (E) = Name_uDisp_Get_Task_Id then
 623             return Uint_13;
 624
 625          elsif Chars (E) = Name_uDisp_Requeue then
 626             return Uint_14;
 627
 628          elsif Chars (E) = Name_uDisp_Timed_Select then
 629             return Uint_15;
 630          end if;
 631       end if;
 632
 633       raise Program_Error;
 634    end Default_Prim_Op_Position;
 635
 636    -----------------------------
 637    -- Expand_Dispatching_Call --
 638    -----------------------------
 639
 640    procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
 641       Loc      : constant Source_Ptr := Sloc (Call_Node);
 642       Call_Typ : constant Entity_Id  := Etype (Call_Node);
 643
 644       Ctrl_Arg   : constant Node_Id   := Controlling_Argument (Call_Node);
 645       Ctrl_Typ   : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
 646       Param_List : constant List_Id   := Parameter_Associations (Call_Node);
 647
 648       Subp            : Entity_Id;
 649       CW_Typ          : Entity_Id;
 650       New_Call        : Node_Id;
 651       New_Call_Name   : Node_Id;
 652       New_Params      : List_Id := No_List;
 653       Param           : Node_Id;
 654       Res_Typ         : Entity_Id;
 655       Subp_Ptr_Typ    : Entity_Id;
 656       Subp_Typ        : Entity_Id;
 657       Typ             : Entity_Id;
 658       Eq_Prim_Op      : Entity_Id := Empty;
 659       Controlling_Tag : Node_Id;
 660
 661       function New_Value (From : Node_Id) return Node_Id;
 662       --  From is the original Expression. New_Value is equivalent to a call
 663       --  to Duplicate_Subexpr with an explicit dereference when From is an
 664       --  access parameter.
 665
 666       ---------------
 667       -- New_Value --
 668       ---------------
 669
 670       function New_Value (From : Node_Id) return Node_Id is
 671          Res : constant Node_Id := Duplicate_Subexpr (From);
 672       begin
 673          if Is_Access_Type (Etype (From)) then
 674             return
 675               Make_Explicit_Dereference (Sloc (From),
 676                 Prefix => Res);
 677          else
 678             return Res;
 679          end if;
 680       end New_Value;
 681
 682       --  Local variables
 683
 684       New_Node          : Node_Id;
 685       SCIL_Node         : Node_Id;
 686       SCIL_Related_Node : Node_Id := Call_Node;
 687
 688    --  Start of processing for Expand_Dispatching_Call
 689
 690    begin
 691       if No_Run_Time_Mode then
 692          Error_Msg_CRT ("tagged types", Call_Node);
 693          return;
 694       end if;
 695
 696       --  Expand_Dispatching_Call is called directly from the semantics,
 697       --  so we only proceed if the expander is active.
 698
 699       if not Full_Expander_Active
 700
 701         --  And there is no need to expand the call if we are compiling under
 702         --  restriction No_Dispatching_Calls; the semantic analyzer has
 703         --  previously notified the violation of this restriction.
 704
 705         or else Restriction_Active (No_Dispatching_Calls)
 706
 707         --  No action needed if the dispatching call has been already expanded
 708
 709         or else Is_Expanded_Dispatching_Call (Name (Call_Node))
 710       then
 711          return;
 712       end if;
 713
 714       --  Set subprogram. If this is an inherited operation that was
 715       --  overridden, the body that is being called is its alias.
 716
 717       Subp := Entity (Name (Call_Node));
 718
 719       if Present (Alias (Subp))
 720         and then Is_Inherited_Operation (Subp)
 721         and then No (DTC_Entity (Subp))
 722       then
 723          Subp := Alias (Subp);
 724       end if;
 725
 726       --  Definition of the class-wide type and the tagged type
 727
 728       --  If the controlling argument is itself a tag rather than a tagged
 729       --  object, then use the class-wide type associated with the subprogram's
 730       --  controlling type. This case can occur when a call to an inherited
 731       --  primitive has an actual that originated from a default parameter
 732       --  given by a tag-indeterminate call and when there is no other
 733       --  controlling argument providing the tag (AI-239 requires dispatching).
 734       --  This capability of dispatching directly by tag is also needed by the
 735       --  implementation of AI-260 (for the generic dispatching constructors).
 736
 737       if Ctrl_Typ = RTE (RE_Tag)
 738         or else (RTE_Available (RE_Interface_Tag)
 739                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
 740       then
 741          CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
 742
 743       --  Class_Wide_Type is applied to the expressions used to initialize
 744       --  CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
 745       --  there are cases where the controlling type is resolved to a specific
 746       --  type (such as for designated types of arguments such as CW'Access).
 747
 748       elsif Is_Access_Type (Ctrl_Typ) then
 749          CW_Typ := Class_Wide_Type (Designated_Type (Ctrl_Typ));
 750
 751       else
 752          CW_Typ := Class_Wide_Type (Ctrl_Typ);
 753       end if;
 754
 755       Typ := Find_Specific_Type (CW_Typ);
 756
 757       if not Is_Limited_Type (Typ) then
 758          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
 759       end if;
 760
 761       --  Dispatching call to C++ primitive. Create a new parameter list
 762       --  with no tag checks.
 763
 764       New_Params := New_List;
 765
 766       if Is_CPP_Class (Typ) then
 767          Param := First_Actual (Call_Node);
 768          while Present (Param) loop
 769             Append_To (New_Params, Relocate_Node (Param));
 770             Next_Actual (Param);
 771          end loop;
 772
 773       --  Dispatching call to Ada primitive
 774
 775       elsif Present (Param_List) then
 776          Apply_Tag_Checks (Call_Node);
 777
 778          Param := First_Actual (Call_Node);
 779          while Present (Param) loop
 780             --  Cases in which we may have generated runtime checks
 781
 782             if Param = Ctrl_Arg
 783               or else Subp = Eq_Prim_Op
 784             then
 785                Append_To (New_Params,
 786                  Duplicate_Subexpr_Move_Checks (Param));
 787
 788             elsif Nkind (Parent (Param)) /= N_Parameter_Association
 789               or else not Is_Accessibility_Actual (Parent (Param))
 790             then
 791                Append_To (New_Params, Relocate_Node (Param));
 792             end if;
 793
 794             Next_Actual (Param);
 795          end loop;
 796       end if;
 797
 798       --  Generate the appropriate subprogram pointer type
 799
 800       if Etype (Subp) = Typ then
 801          Res_Typ := CW_Typ;
 802       else
 803          Res_Typ := Etype (Subp);
 804       end if;
 805
 806       Subp_Typ     := Create_Itype (E_Subprogram_Type, Call_Node);
 807       Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
 808       Set_Etype          (Subp_Typ, Res_Typ);
 809       Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
 810       Set_Convention     (Subp_Typ, Convention (Subp));
 811
 812       --  Notify gigi that the designated type is a dispatching primitive
 813
 814       Set_Is_Dispatch_Table_Entity (Subp_Typ);
 815
 816       --  Create a new list of parameters which is a copy of the old formal
 817       --  list including the creation of a new set of matching entities.
 818
 819       declare
 820          Old_Formal : Entity_Id := First_Formal (Subp);
 821          New_Formal : Entity_Id;
 822          Extra      : Entity_Id := Empty;
 823
 824       begin
 825          if Present (Old_Formal) then
 826             New_Formal := New_Copy (Old_Formal);
 827             Set_First_Entity (Subp_Typ, New_Formal);
 828             Param := First_Actual (Call_Node);
 829
 830             loop
 831                Set_Scope (New_Formal, Subp_Typ);
 832
 833                --  Change all the controlling argument types to be class-wide
 834                --  to avoid a recursion in dispatching.
 835
 836                if Is_Controlling_Formal (New_Formal) then
 837                   Set_Etype (New_Formal, Etype (Param));
 838                end if;
 839
 840                --  If the type of the formal is an itype, there was code here
 841                --  introduced in 1998 in revision 1.46, to create a new itype
 842                --  by copy. This seems useless, and in fact leads to semantic
 843                --  errors when the itype is the completion of a type derived
 844                --  from a private type.
 845
 846                Extra := New_Formal;
 847                Next_Formal (Old_Formal);
 848                exit when No (Old_Formal);
 849
 850                Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
 851                Next_Entity (New_Formal);
 852                Next_Actual (Param);
 853             end loop;
 854
 855             Set_Next_Entity (New_Formal, Empty);
 856             Set_Last_Entity (Subp_Typ, Extra);
 857          end if;
 858
 859          --  Now that the explicit formals have been duplicated, any extra
 860          --  formals needed by the subprogram must be created.
 861
 862          if Present (Extra) then
 863             Set_Extra_Formal (Extra, Empty);
 864          end if;
 865
 866          Create_Extra_Formals (Subp_Typ);
 867       end;
 868
 869       --  Complete description of pointer type, including size information, as
 870       --  must be done with itypes to prevent order-of-elaboration anomalies
 871       --  in gigi.
 872
 873       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
 874       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
 875       Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
 876       Layout_Type    (Subp_Ptr_Typ);
 877
 878       --  If the controlling argument is a value of type Ada.Tag or an abstract
 879       --  interface class-wide type then use it directly. Otherwise, the tag
 880       --  must be extracted from the controlling object.
 881
 882       if Ctrl_Typ = RTE (RE_Tag)
 883         or else (RTE_Available (RE_Interface_Tag)
 884                   and then Ctrl_Typ = RTE (RE_Interface_Tag))
 885       then
 886          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
 887
 888       --  Extract the tag from an unchecked type conversion. Done to avoid
 889       --  the expansion of additional code just to obtain the value of such
 890       --  tag because the current management of interface type conversions
 891       --  generates in some cases this unchecked type conversion with the
 892       --  tag of the object (see Expand_Interface_Conversion).
 893
 894       elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
 895         and then
 896           (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
 897             or else
 898               (RTE_Available (RE_Interface_Tag)
 899                 and then
 900                   Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
 901       then
 902          Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
 903
 904       --  Ada 2005 (AI-251): Abstract interface class-wide type
 905
 906       elsif Is_Interface (Ctrl_Typ)
 907         and then Is_Class_Wide_Type (Ctrl_Typ)
 908       then
 909          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
 910
 911       else
 912          Controlling_Tag :=
 913            Make_Selected_Component (Loc,
 914              Prefix        => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
 915              Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
 916       end if;
 917
 918       --  Handle dispatching calls to predefined primitives
 919
 920       if Is_Predefined_Dispatching_Operation (Subp)
 921         or else Is_Predefined_Dispatching_Alias (Subp)
 922       then
 923          Build_Get_Predefined_Prim_Op_Address (Loc,
 924            Tag_Node => Controlling_Tag,
 925            Position => DT_Position (Subp),
 926            New_Node => New_Node);
 927
 928       --  Handle dispatching calls to user-defined primitives
 929
 930       else
 931          Build_Get_Prim_Op_Address (Loc,
 932            Typ      => Underlying_Type (Find_Dispatching_Type (Subp)),
 933            Tag_Node => Controlling_Tag,
 934            Position => DT_Position (Subp),
 935            New_Node => New_Node);
 936       end if;
 937
 938       New_Call_Name :=
 939         Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
 940
 941       --  Generate the SCIL node for this dispatching call. Done now because
 942       --  attribute SCIL_Controlling_Tag must be set after the new call name
 943       --  is built to reference the nodes that will see the SCIL backend
 944       --  (because Build_Get_Prim_Op_Address generates an unchecked type
 945       --  conversion which relocates the controlling tag node).
 946
 947       if Generate_SCIL then
 948          SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
 949          Set_SCIL_Entity      (SCIL_Node, Typ);
 950          Set_SCIL_Target_Prim (SCIL_Node, Subp);
 951
 952          --  Common case: the controlling tag is the tag of an object
 953          --  (for example, obj.tag)
 954
 955          if Nkind (Controlling_Tag) = N_Selected_Component then
 956             Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
 957
 958          --  Handle renaming of selected component
 959
 960          elsif Nkind (Controlling_Tag) = N_Identifier
 961            and then Nkind (Parent (Entity (Controlling_Tag))) =
 962                                              N_Object_Renaming_Declaration
 963            and then Nkind (Name (Parent (Entity (Controlling_Tag)))) =
 964                                              N_Selected_Component
 965          then
 966             Set_SCIL_Controlling_Tag (SCIL_Node,
 967               Name (Parent (Entity (Controlling_Tag))));
 968
 969          --  If the controlling tag is an identifier, the SCIL node references
 970          --  the corresponding object or parameter declaration
 971
 972          elsif Nkind (Controlling_Tag) = N_Identifier
 973            and then Nkind_In (Parent (Entity (Controlling_Tag)),
 974                               N_Object_Declaration,
 975                               N_Parameter_Specification)
 976          then
 977             Set_SCIL_Controlling_Tag (SCIL_Node,
 978               Parent (Entity (Controlling_Tag)));
 979
 980          --  If the controlling tag is a dereference, the SCIL node references
 981          --  the corresponding object or parameter declaration
 982
 983          elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
 984             and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
 985             and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
 986                                N_Object_Declaration,
 987                                N_Parameter_Specification)
 988          then
 989             Set_SCIL_Controlling_Tag (SCIL_Node,
 990               Parent (Entity (Prefix (Controlling_Tag))));
 991
 992          --  For a direct reference of the tag of the type the SCIL node
 993          --  references the internal object declaration containing the tag
 994          --  of the type.
 995
 996          elsif Nkind (Controlling_Tag) = N_Attribute_Reference
 997             and then Attribute_Name (Controlling_Tag) = Name_Tag
 998          then
 999             Set_SCIL_Controlling_Tag (SCIL_Node,
1000               Parent
1001                 (Node
1002                   (First_Elmt
1003                     (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
1004
1005          --  Interfaces are not supported. For now we leave the SCIL node
1006          --  decorated with the Controlling_Tag. More work needed here???
1007
1008          elsif Is_Interface (Etype (Controlling_Tag)) then
1009             Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
1010
1011          else
1012             pragma Assert (False);
1013             null;
1014          end if;
1015       end if;
1016
1017       if Nkind (Call_Node) = N_Function_Call then
1018          New_Call :=
1019            Make_Function_Call (Loc,
1020              Name                   => New_Call_Name,
1021              Parameter_Associations => New_Params);
1022
1023          --  If this is a dispatching "=", we must first compare the tags so
1024          --  we generate: x.tag = y.tag and then x = y
1025
1026          if Subp = Eq_Prim_Op then
1027             Param := First_Actual (Call_Node);
1028             New_Call :=
1029               Make_And_Then (Loc,
1030                 Left_Opnd =>
1031                      Make_Op_Eq (Loc,
1032                        Left_Opnd =>
1033                          Make_Selected_Component (Loc,
1034                            Prefix        => New_Value (Param),
1035                            Selector_Name =>
1036                              New_Reference_To (First_Tag_Component (Typ),
1037                                                Loc)),
1038
1039                        Right_Opnd =>
1040                          Make_Selected_Component (Loc,
1041                            Prefix        =>
1042                              Unchecked_Convert_To (Typ,
1043                                New_Value (Next_Actual (Param))),
1044                            Selector_Name =>
1045                              New_Reference_To
1046                                (First_Tag_Component (Typ), Loc))),
1047                 Right_Opnd => New_Call);
1048
1049             SCIL_Related_Node := Right_Opnd (New_Call);
1050          end if;
1051
1052       else
1053          New_Call :=
1054            Make_Procedure_Call_Statement (Loc,
1055              Name                   => New_Call_Name,
1056              Parameter_Associations => New_Params);
1057       end if;
1058
1059       --  Register the dispatching call in the call graph nodes table
1060
1061       Register_CG_Node (Call_Node);
1062
1063       Rewrite (Call_Node, New_Call);
1064
1065       --  Associate the SCIL node of this dispatching call
1066
1067       if Generate_SCIL then
1068          Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
1069       end if;
1070
1071       --  Suppress all checks during the analysis of the expanded code
1072       --  to avoid the generation of spurious warnings under ZFP run-time.
1073
1074       Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
1075
1076       --  For functions returning interface types add implicit conversion to
1077       --  force the displacement of the pointer to the object to reference
1078       --  the corresponding secondary dispatch table. This is needed to
1079       --  handle well nested calls through secondary dispatch tables
1080       --  (for example Obj.Prim1.Prim2).
1081
1082       if Is_Interface (Res_Typ) then
1083          Rewrite (Call_Node,
1084            Make_Type_Conversion (Loc,
1085              Subtype_Mark => New_Occurrence_Of (Res_Typ, Loc),
1086              Expression => Relocate_Node (Call_Node)));
1087          Set_Etype (Call_Node, Res_Typ);
1088          Expand_Interface_Conversion (Call_Node, Is_Static => False);
1089          Force_Evaluation (Call_Node);
1090
1091          pragma Assert (Nkind (Call_Node) = N_Explicit_Dereference
1092            and then Nkind (Prefix (Call_Node)) = N_Identifier
1093            and then Nkind (Parent (Entity (Prefix (Call_Node))))
1094                              = N_Object_Declaration);
1095          Set_Assignment_OK (Parent (Entity (Prefix (Call_Node))));
1096
1097          if Nkind (Parent (Call_Node)) = N_Object_Declaration then
1098             Set_Assignment_OK (Parent (Call_Node));
1099          end if;
1100       end if;
1101    end Expand_Dispatching_Call;
1102
1103    ---------------------------------
1104    -- Expand_Interface_Conversion --
1105    ---------------------------------
1106
1107    procedure Expand_Interface_Conversion
1108      (N         : Node_Id;
1109       Is_Static : Boolean := True)
1110    is
1111       Loc         : constant Source_Ptr := Sloc (N);
1112       Etyp        : constant Entity_Id  := Etype (N);
1113       Operand     : constant Node_Id    := Expression (N);
1114       Operand_Typ : Entity_Id           := Etype (Operand);
1115       Func        : Node_Id;
1116       Iface_Typ   : Entity_Id           := Etype (N);
1117       Iface_Tag   : Entity_Id;
1118
1119    begin
1120       --  Ada 2005 (AI-345): Handle synchronized interface type derivations
1121
1122       if Is_Concurrent_Type (Operand_Typ) then
1123          Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
1124       end if;
1125
1126       --  Handle access to class-wide interface types
1127
1128       if Is_Access_Type (Iface_Typ) then
1129          Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
1130       end if;
1131
1132       --  Handle class-wide interface types. This conversion can appear
1133       --  explicitly in the source code. Example: I'Class (Obj)
1134
1135       if Is_Class_Wide_Type (Iface_Typ) then
1136          Iface_Typ := Root_Type (Iface_Typ);
1137       end if;
1138
1139       --  If the target type is a tagged synchronized type, the dispatch table
1140       --  info is in the corresponding record type.
1141
1142       if Is_Concurrent_Type (Iface_Typ) then
1143          Iface_Typ := Corresponding_Record_Type (Iface_Typ);
1144       end if;
1145
1146       --  Handle private types
1147
1148       Iface_Typ := Underlying_Type (Iface_Typ);
1149
1150       --  Freeze the entity associated with the target interface to have
1151       --  available the attribute Access_Disp_Table.
1152
1153       Freeze_Before (N, Iface_Typ);
1154
1155       pragma Assert (not Is_Static
1156         or else (not Is_Class_Wide_Type (Iface_Typ)
1157                   and then Is_Interface (Iface_Typ)));
1158
1159       if not Tagged_Type_Expansion then
1160          if VM_Target /= No_VM then
1161             if Is_Access_Type (Operand_Typ) then
1162                Operand_Typ := Designated_Type (Operand_Typ);
1163             end if;
1164
1165             if Is_Class_Wide_Type (Operand_Typ) then
1166                Operand_Typ := Root_Type (Operand_Typ);
1167             end if;
1168
1169             if not Is_Static
1170               and then Operand_Typ /= Iface_Typ
1171             then
1172                Insert_Action (N,
1173                  Make_Procedure_Call_Statement (Loc,
1174                    Name => New_Occurrence_Of
1175                             (RTE (RE_Check_Interface_Conversion), Loc),
1176                    Parameter_Associations => New_List (
1177                      Make_Attribute_Reference (Loc,
1178                        Prefix => Duplicate_Subexpr (Expression (N)),
1179                        Attribute_Name => Name_Tag),
1180                      Make_Attribute_Reference (Loc,
1181                        Prefix         => New_Reference_To (Iface_Typ, Loc),
1182                        Attribute_Name => Name_Tag))));
1183             end if;
1184
1185             --  Just do a conversion ???
1186
1187             Rewrite (N, Unchecked_Convert_To (Etype (N), N));
1188             Analyze (N);
1189          end if;
1190
1191          return;
1192       end if;
1193
1194       if not Is_Static then
1195
1196          --  Give error if configurable run time and Displace not available
1197
1198          if not RTE_Available (RE_Displace) then
1199             Error_Msg_CRT ("dynamic interface conversion", N);
1200             return;
1201          end if;
1202
1203          --  Handle conversion of access-to-class-wide interface types. Target
1204          --  can be an access to an object or an access to another class-wide
1205          --  interface (see -1- and -2- in the following example):
1206
1207          --     type Iface1_Ref is access all Iface1'Class;
1208          --     type Iface2_Ref is access all Iface1'Class;
1209
1210          --     Acc1 : Iface1_Ref := new ...
1211          --     Obj  : Obj_Ref    := Obj_Ref (Acc);    -- 1
1212          --     Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
1213
1214          if Is_Access_Type (Operand_Typ) then
1215             Rewrite (N,
1216               Unchecked_Convert_To (Etype (N),
1217                 Make_Function_Call (Loc,
1218                   Name => New_Reference_To (RTE (RE_Displace), Loc),
1219                   Parameter_Associations => New_List (
1220
1221                     Unchecked_Convert_To (RTE (RE_Address),
1222                       Relocate_Node (Expression (N))),
1223
1224                     New_Occurrence_Of
1225                       (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1226                        Loc)))));
1227
1228             Analyze (N);
1229             return;
1230          end if;
1231
1232          Rewrite (N,
1233            Make_Function_Call (Loc,
1234              Name => New_Reference_To (RTE (RE_Displace), Loc),
1235              Parameter_Associations => New_List (
1236                Make_Attribute_Reference (Loc,
1237                  Prefix => Relocate_Node (Expression (N)),
1238                  Attribute_Name => Name_Address),
1239
1240                New_Occurrence_Of
1241                  (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
1242                   Loc))));
1243
1244          Analyze (N);
1245
1246          --  If the target is a class-wide interface we change the type of the
1247          --  data returned by IW_Convert to indicate that this is a dispatching
1248          --  call.
1249
1250          declare
1251             New_Itype : Entity_Id;
1252
1253          begin
1254             New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
1255             Set_Etype (New_Itype, New_Itype);
1256             Set_Directly_Designated_Type (New_Itype, Etyp);
1257
1258             Rewrite (N,
1259               Make_Explicit_Dereference (Loc,
1260                 Prefix =>
1261                   Unchecked_Convert_To (New_Itype, Relocate_Node (N))));
1262             Analyze (N);
1263             Freeze_Itype (New_Itype, N);
1264
1265             return;
1266          end;
1267       end if;
1268
1269       Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
1270       pragma Assert (Iface_Tag /= Empty);
1271
1272       --  Keep separate access types to interfaces because one internal
1273       --  function is used to handle the null value (see following comments)
1274
1275       if not Is_Access_Type (Etype (N)) then
1276
1277          --  Statically displace the pointer to the object to reference
1278          --  the component containing the secondary dispatch table.
1279
1280          Rewrite (N,
1281            Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
1282              Make_Selected_Component (Loc,
1283                Prefix => Relocate_Node (Expression (N)),
1284                Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
1285
1286       else
1287          --  Build internal function to handle the case in which the
1288          --  actual is null. If the actual is null returns null because
1289          --  no displacement is required; otherwise performs a type
1290          --  conversion that will be expanded in the code that returns
1291          --  the value of the displaced actual. That is:
1292
1293          --     function Func (O : Address) return Iface_Typ is
1294          --        type Op_Typ is access all Operand_Typ;
1295          --        Aux : Op_Typ := To_Op_Typ (O);
1296          --     begin
1297          --        if O = Null_Address then
1298          --           return null;
1299          --        else
1300          --           return Iface_Typ!(Aux.Iface_Tag'Address);
1301          --        end if;
1302          --     end Func;
1303
1304          declare
1305             Desig_Typ    : Entity_Id;
1306             Fent         : Entity_Id;
1307             New_Typ_Decl : Node_Id;
1308             Stats        : List_Id;
1309
1310          begin
1311             Desig_Typ := Etype (Expression (N));
1312
1313             if Is_Access_Type (Desig_Typ) then
1314                Desig_Typ :=
1315                  Available_View (Directly_Designated_Type (Desig_Typ));
1316             end if;
1317
1318             if Is_Concurrent_Type (Desig_Typ) then
1319                Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
1320             end if;
1321
1322             New_Typ_Decl :=
1323               Make_Full_Type_Declaration (Loc,
1324                 Defining_Identifier => Make_Temporary (Loc, 'T'),
1325                 Type_Definition =>
1326                   Make_Access_To_Object_Definition (Loc,
1327                     All_Present            => True,
1328                     Null_Exclusion_Present => False,
1329                     Constant_Present       => False,
1330                     Subtype_Indication     =>
1331                       New_Reference_To (Desig_Typ, Loc)));
1332
1333             Stats := New_List (
1334               Make_Simple_Return_Statement (Loc,
1335                 Unchecked_Convert_To (Etype (N),
1336                   Make_Attribute_Reference (Loc,
1337                     Prefix =>
1338                       Make_Selected_Component (Loc,
1339                         Prefix =>
1340                           Unchecked_Convert_To
1341                             (Defining_Identifier (New_Typ_Decl),
1342                              Make_Identifier (Loc, Name_uO)),
1343                         Selector_Name =>
1344                           New_Occurrence_Of (Iface_Tag, Loc)),
1345                     Attribute_Name => Name_Address))));
1346
1347             --  If the type is null-excluding, no need for the null branch.
1348             --  Otherwise we need to check for it and return null.
1349
1350             if not Can_Never_Be_Null (Etype (N)) then
1351                Stats := New_List (
1352                  Make_If_Statement (Loc,
1353                   Condition       =>
1354                     Make_Op_Eq (Loc,
1355                        Left_Opnd  => Make_Identifier (Loc, Name_uO),
1356                        Right_Opnd => New_Reference_To
1357                                        (RTE (RE_Null_Address), Loc)),
1358
1359                  Then_Statements => New_List (
1360                    Make_Simple_Return_Statement (Loc,
1361                      Make_Null (Loc))),
1362                  Else_Statements => Stats));
1363             end if;
1364
1365             Fent := Make_Temporary (Loc, 'F');
1366             Func :=
1367               Make_Subprogram_Body (Loc,
1368                 Specification =>
1369                   Make_Function_Specification (Loc,
1370                     Defining_Unit_Name => Fent,
1371
1372                     Parameter_Specifications => New_List (
1373                       Make_Parameter_Specification (Loc,
1374                         Defining_Identifier =>
1375                           Make_Defining_Identifier (Loc, Name_uO),
1376                         Parameter_Type =>
1377                           New_Reference_To (RTE (RE_Address), Loc))),
1378
1379                     Result_Definition =>
1380                       New_Reference_To (Etype (N), Loc)),
1381
1382                 Declarations => New_List (New_Typ_Decl),
1383
1384                 Handled_Statement_Sequence =>
1385                   Make_Handled_Sequence_Of_Statements (Loc, Stats));
1386
1387             --  Place function body before the expression containing the
1388             --  conversion. We suppress all checks because the body of the
1389             --  internally generated function already takes care of the case
1390             --  in which the actual is null; therefore there is no need to
1391             --  double check that the pointer is not null when the program
1392             --  executes the alternative that performs the type conversion).
1393
1394             Insert_Action (N, Func, Suppress => All_Checks);
1395
1396             if Is_Access_Type (Etype (Expression (N))) then
1397
1398                --  Generate: Func (Address!(Expression))
1399
1400                Rewrite (N,
1401                  Make_Function_Call (Loc,
1402                    Name => New_Reference_To (Fent, Loc),
1403                    Parameter_Associations => New_List (
1404                      Unchecked_Convert_To (RTE (RE_Address),
1405                        Relocate_Node (Expression (N))))));
1406
1407             else
1408                --  Generate: Func (Operand_Typ!(Expression)'Address)
1409
1410                Rewrite (N,
1411                  Make_Function_Call (Loc,
1412                    Name => New_Reference_To (Fent, Loc),
1413                    Parameter_Associations => New_List (
1414                      Make_Attribute_Reference (Loc,
1415                        Prefix  => Unchecked_Convert_To (Operand_Typ,
1416                                     Relocate_Node (Expression (N))),
1417                        Attribute_Name => Name_Address))));
1418             end if;
1419          end;
1420       end if;
1421
1422       Analyze (N);
1423    end Expand_Interface_Conversion;
1424
1425    ------------------------------
1426    -- Expand_Interface_Actuals --
1427    ------------------------------
1428
1429    procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
1430       Actual     : Node_Id;
1431       Actual_Dup : Node_Id;
1432       Actual_Typ : Entity_Id;
1433       Anon       : Entity_Id;
1434       Conversion : Node_Id;
1435       Formal     : Entity_Id;
1436       Formal_Typ : Entity_Id;
1437       Subp       : Entity_Id;
1438       Formal_DDT : Entity_Id;
1439       Actual_DDT : Entity_Id;
1440
1441    begin
1442       --  This subprogram is called directly from the semantics, so we need a
1443       --  check to see whether expansion is active before proceeding.
1444
1445       if not Expander_Active then
1446          return;
1447       end if;
1448
1449       --  Call using access to subprogram with explicit dereference
1450
1451       if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
1452          Subp := Etype (Name (Call_Node));
1453
1454       --  Call using selected component
1455
1456       elsif Nkind (Name (Call_Node)) = N_Selected_Component then
1457          Subp := Entity (Selector_Name (Name (Call_Node)));
1458
1459       --  Call using direct name
1460
1461       else
1462          Subp := Entity (Name (Call_Node));
1463       end if;
1464
1465       --  Ada 2005 (AI-251): Look for interface type formals to force "this"
1466       --  displacement
1467
1468       Formal := First_Formal (Subp);
1469       Actual := First_Actual (Call_Node);
1470       while Present (Formal) loop
1471          Formal_Typ := Etype (Formal);
1472
1473          if Ekind (Formal_Typ) = E_Record_Type_With_Private then
1474             Formal_Typ := Full_View (Formal_Typ);
1475          end if;
1476
1477          if Is_Access_Type (Formal_Typ) then
1478             Formal_DDT := Directly_Designated_Type (Formal_Typ);
1479          end if;
1480
1481          Actual_Typ := Etype (Actual);
1482
1483          if Is_Access_Type (Actual_Typ) then
1484             Actual_DDT := Directly_Designated_Type (Actual_Typ);
1485          end if;
1486
1487          if Is_Interface (Formal_Typ)
1488            and then Is_Class_Wide_Type (Formal_Typ)
1489          then
1490             --  No need to displace the pointer if the type of the actual
1491             --  coincides with the type of the formal.
1492
1493             if Actual_Typ = Formal_Typ then
1494                null;
1495
1496             --  No need to displace the pointer if the interface type is
1497             --  a parent of the type of the actual because in this case the
1498             --  interface primitives are located in the primary dispatch table.
1499
1500             elsif Is_Ancestor (Formal_Typ, Actual_Typ,
1501                                Use_Full_View => True)
1502             then
1503                null;
1504
1505             --  Implicit conversion to the class-wide formal type to force
1506             --  the displacement of the pointer.
1507
1508             else
1509                --  Normally, expansion of actuals for calls to build-in-place
1510                --  functions happens as part of Expand_Actuals, but in this
1511                --  case the call will be wrapped in a conversion and soon after
1512                --  expanded further to handle the displacement for a class-wide
1513                --  interface conversion, so if this is a BIP call then we need
1514                --  to handle it now.
1515
1516                if Ada_Version >= Ada_2005
1517                  and then Is_Build_In_Place_Function_Call (Actual)
1518                then
1519                   Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
1520                end if;
1521
1522                Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
1523                Rewrite (Actual, Conversion);
1524                Analyze_And_Resolve (Actual, Formal_Typ);
1525             end if;
1526
1527          --  Access to class-wide interface type
1528
1529          elsif Is_Access_Type (Formal_Typ)
1530            and then Is_Interface (Formal_DDT)
1531            and then Is_Class_Wide_Type (Formal_DDT)
1532            and then Interface_Present_In_Ancestor
1533                       (Typ   => Actual_DDT,
1534                        Iface => Etype (Formal_DDT))
1535          then
1536             --  Handle attributes 'Access and 'Unchecked_Access
1537
1538             if Nkind (Actual) = N_Attribute_Reference
1539               and then
1540                (Attribute_Name (Actual) = Name_Access
1541                  or else Attribute_Name (Actual) = Name_Unchecked_Access)
1542             then
1543                --  This case must have been handled by the analysis and
1544                --  expansion of 'Access. The only exception is when types
1545                --  match and no further expansion is required.
1546
1547                pragma Assert (Base_Type (Etype (Prefix (Actual)))
1548                                = Base_Type (Formal_DDT));
1549                null;
1550
1551             --  No need to displace the pointer if the type of the actual
1552             --  coincides with the type of the formal.
1553
1554             elsif Actual_DDT = Formal_DDT then
1555                null;
1556
1557             --  No need to displace the pointer if the interface type is
1558             --  a parent of the type of the actual because in this case the
1559             --  interface primitives are located in the primary dispatch table.
1560
1561             elsif Is_Ancestor (Formal_DDT, Actual_DDT,
1562                                Use_Full_View => True)
1563             then
1564                null;
1565
1566             else
1567                Actual_Dup := Relocate_Node (Actual);
1568
1569                if From_With_Type (Actual_Typ) then
1570
1571                   --  If the type of the actual parameter comes from a limited
1572                   --  with-clause and the non-limited view is already available
1573                   --  we replace the anonymous access type by a duplicate
1574                   --  declaration whose designated type is the non-limited view
1575
1576                   if Ekind (Actual_DDT) = E_Incomplete_Type
1577                     and then Present (Non_Limited_View (Actual_DDT))
1578                   then
1579                      Anon := New_Copy (Actual_Typ);
1580
1581                      if Is_Itype (Anon) then
1582                         Set_Scope (Anon, Current_Scope);
1583                      end if;
1584
1585                      Set_Directly_Designated_Type (Anon,
1586                        Non_Limited_View (Actual_DDT));
1587                      Set_Etype (Actual_Dup, Anon);
1588
1589                   elsif Is_Class_Wide_Type (Actual_DDT)
1590                     and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
1591                     and then Present (Non_Limited_View (Etype (Actual_DDT)))
1592                   then
1593                      Anon := New_Copy (Actual_Typ);
1594
1595                      if Is_Itype (Anon) then
1596                         Set_Scope (Anon, Current_Scope);
1597                      end if;
1598
1599                      Set_Directly_Designated_Type (Anon,
1600                        New_Copy (Actual_DDT));
1601                      Set_Class_Wide_Type (Directly_Designated_Type (Anon),
1602                        New_Copy (Class_Wide_Type (Actual_DDT)));
1603                      Set_Etype (Directly_Designated_Type (Anon),
1604                        Non_Limited_View (Etype (Actual_DDT)));
1605                      Set_Etype (
1606                        Class_Wide_Type (Directly_Designated_Type (Anon)),
1607                        Non_Limited_View (Etype (Actual_DDT)));
1608                      Set_Etype (Actual_Dup, Anon);
1609                   end if;
1610                end if;
1611
1612                Conversion := Convert_To (Formal_Typ, Actual_Dup);
1613                Rewrite (Actual, Conversion);
1614                Analyze_And_Resolve (Actual, Formal_Typ);
1615             end if;
1616          end if;
1617
1618          Next_Actual (Actual);
1619          Next_Formal (Formal);
1620       end loop;
1621    end Expand_Interface_Actuals;
1622
1623    ----------------------------
1624    -- Expand_Interface_Thunk --
1625    ----------------------------
1626
1627    procedure Expand_Interface_Thunk
1628      (Prim       : Node_Id;
1629       Thunk_Id   : out Entity_Id;
1630       Thunk_Code : out Node_Id)
1631    is
1632       Loc     : constant Source_Ptr := Sloc (Prim);
1633       Actuals : constant List_Id    := New_List;
1634       Decl    : constant List_Id    := New_List;
1635       Formals : constant List_Id    := New_List;
1636       Target  : constant Entity_Id  := Ultimate_Alias (Prim);
1637
1638       Decl_1        : Node_Id;
1639       Decl_2        : Node_Id;
1640       Expr          : Node_Id;
1641       Formal        : Node_Id;
1642       Ftyp          : Entity_Id;
1643       Iface_Formal  : Node_Id;
1644       New_Arg       : Node_Id;
1645       Offset_To_Top : Node_Id;
1646       Target_Formal : Entity_Id;
1647
1648    begin
1649       Thunk_Id   := Empty;
1650       Thunk_Code := Empty;
1651
1652       --  No thunk needed if the primitive has been eliminated
1653
1654       if Is_Eliminated (Ultimate_Alias (Prim)) then
1655          return;
1656
1657       --  In case of primitives that are functions without formals and a
1658       --  controlling result there is no need to build the thunk.
1659
1660       elsif not Present (First_Formal (Target)) then
1661          pragma Assert (Ekind (Target) = E_Function
1662            and then Has_Controlling_Result (Target));
1663          return;
1664       end if;
1665
1666       --  Duplicate the formals of the Target primitive. In the thunk, the type
1667       --  of the controlling formal is the covered interface type (instead of
1668       --  the target tagged type). Done to avoid problems with discriminated
1669       --  tagged types because, if the controlling type has discriminants with
1670       --  default values, then the type conversions done inside the body of
1671       --  the thunk (after the displacement of the pointer to the base of the
1672       --  actual object) generate code that modify its contents.
1673
1674       --  Note: This special management is not done for predefined primitives
1675       --  because???
1676
1677       if not Is_Predefined_Dispatching_Operation (Prim) then
1678          Iface_Formal := First_Formal (Interface_Alias (Prim));
1679       end if;
1680
1681       Formal := First_Formal (Target);
1682       while Present (Formal) loop
1683          Ftyp := Etype (Formal);
1684
1685          --  Use the interface type as the type of the controlling formal (see
1686          --  comment above).
1687
1688          if not Is_Controlling_Formal (Formal)
1689            or else Is_Predefined_Dispatching_Operation (Prim)
1690          then
1691             Ftyp := Etype (Formal);
1692             Expr := New_Copy_Tree (Expression (Parent (Formal)));
1693          else
1694             Ftyp := Etype (Iface_Formal);
1695             Expr := Empty;
1696          end if;
1697
1698          Append_To (Formals,
1699            Make_Parameter_Specification (Loc,
1700              Defining_Identifier =>
1701                Make_Defining_Identifier (Sloc (Formal),
1702                  Chars => Chars (Formal)),
1703              In_Present => In_Present (Parent (Formal)),
1704              Out_Present => Out_Present (Parent (Formal)),
1705              Parameter_Type => New_Reference_To (Ftyp, Loc),
1706              Expression => Expr));
1707
1708          if not Is_Predefined_Dispatching_Operation (Prim) then
1709             Next_Formal (Iface_Formal);
1710          end if;
1711
1712          Next_Formal (Formal);
1713       end loop;
1714
1715       Target_Formal := First_Formal (Target);
1716       Formal        := First (Formals);
1717       while Present (Formal) loop
1718
1719          --  If the parent is a constrained discriminated type, then the
1720          --  primitive operation will have been defined on a first subtype.
1721          --  For proper matching with controlling type, use base type.
1722
1723          if Ekind (Target_Formal) = E_In_Parameter
1724            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1725          then
1726             Ftyp :=
1727               Base_Type (Directly_Designated_Type (Etype (Target_Formal)));
1728          else
1729             Ftyp := Base_Type (Etype (Target_Formal));
1730          end if;
1731
1732          --  For concurrent types, the relevant information is found in the
1733          --  Corresponding_Record_Type, rather than the type entity itself.
1734
1735          if Is_Concurrent_Type (Ftyp) then
1736             Ftyp := Corresponding_Record_Type (Ftyp);
1737          end if;
1738
1739          if Ekind (Target_Formal) = E_In_Parameter
1740            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1741            and then Is_Controlling_Formal (Target_Formal)
1742          then
1743             --  Generate:
1744             --     type T is access all <<type of the target formal>>
1745             --     S : Storage_Offset := Storage_Offset!(Formal)
1746             --                            - Offset_To_Top (address!(Formal))
1747
1748             Decl_2 :=
1749               Make_Full_Type_Declaration (Loc,
1750                 Defining_Identifier => Make_Temporary (Loc, 'T'),
1751                 Type_Definition =>
1752                   Make_Access_To_Object_Definition (Loc,
1753                     All_Present            => True,
1754                     Null_Exclusion_Present => False,
1755                     Constant_Present       => False,
1756                     Subtype_Indication     =>
1757                       New_Reference_To (Ftyp, Loc)));
1758
1759             New_Arg :=
1760               Unchecked_Convert_To (RTE (RE_Address),
1761                 New_Reference_To (Defining_Identifier (Formal), Loc));
1762
1763             if not RTE_Available (RE_Offset_To_Top) then
1764                Offset_To_Top :=
1765                  Build_Offset_To_Top (Loc, New_Arg);
1766             else
1767                Offset_To_Top :=
1768                  Make_Function_Call (Loc,
1769                    Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1770                    Parameter_Associations => New_List (New_Arg));
1771             end if;
1772
1773             Decl_1 :=
1774               Make_Object_Declaration (Loc,
1775                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1776                 Constant_Present    => True,
1777                 Object_Definition   =>
1778                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
1779                 Expression          =>
1780                   Make_Op_Subtract (Loc,
1781                     Left_Opnd  =>
1782                       Unchecked_Convert_To
1783                         (RTE (RE_Storage_Offset),
1784                          New_Reference_To (Defining_Identifier (Formal), Loc)),
1785                      Right_Opnd =>
1786                        Offset_To_Top));
1787
1788             Append_To (Decl, Decl_2);
1789             Append_To (Decl, Decl_1);
1790
1791             --  Reference the new actual. Generate:
1792             --    T!(S)
1793
1794             Append_To (Actuals,
1795               Unchecked_Convert_To
1796                 (Defining_Identifier (Decl_2),
1797                  New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1798
1799          elsif Is_Controlling_Formal (Target_Formal) then
1800
1801             --  Generate:
1802             --     S1 : Storage_Offset := Storage_Offset!(Formal'Address)
1803             --                             - Offset_To_Top (Formal'Address)
1804             --     S2 : Addr_Ptr := Addr_Ptr!(S1)
1805
1806             New_Arg :=
1807               Make_Attribute_Reference (Loc,
1808                 Prefix =>
1809                   New_Reference_To (Defining_Identifier (Formal), Loc),
1810                 Attribute_Name =>
1811                   Name_Address);
1812
1813             if not RTE_Available (RE_Offset_To_Top) then
1814                Offset_To_Top :=
1815                  Build_Offset_To_Top (Loc, New_Arg);
1816             else
1817                Offset_To_Top :=
1818                  Make_Function_Call (Loc,
1819                    Name => New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1820                    Parameter_Associations => New_List (New_Arg));
1821             end if;
1822
1823             Decl_1 :=
1824               Make_Object_Declaration (Loc,
1825                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1826                 Constant_Present    => True,
1827                 Object_Definition   =>
1828                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
1829                 Expression          =>
1830                   Make_Op_Subtract (Loc,
1831                     Left_Opnd =>
1832                       Unchecked_Convert_To
1833                         (RTE (RE_Storage_Offset),
1834                          Make_Attribute_Reference (Loc,
1835                            Prefix =>
1836                              New_Reference_To
1837                                (Defining_Identifier (Formal), Loc),
1838                            Attribute_Name => Name_Address)),
1839                     Right_Opnd =>
1840                       Offset_To_Top));
1841
1842             Decl_2 :=
1843               Make_Object_Declaration (Loc,
1844                 Defining_Identifier => Make_Temporary (Loc, 'S'),
1845                 Constant_Present    => True,
1846                 Object_Definition   =>
1847                   New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1848                 Expression          =>
1849                   Unchecked_Convert_To
1850                     (RTE (RE_Addr_Ptr),
1851                      New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1852
1853             Append_To (Decl, Decl_1);
1854             Append_To (Decl, Decl_2);
1855
1856             --  Reference the new actual, generate:
1857             --    Target_Formal (S2.all)
1858
1859             Append_To (Actuals,
1860               Unchecked_Convert_To (Ftyp,
1861                  Make_Explicit_Dereference (Loc,
1862                    New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1863
1864          --  Ensure proper matching of access types. Required to avoid
1865          --  reporting spurious errors.
1866
1867          elsif Is_Access_Type (Etype (Target_Formal)) then
1868             Append_To (Actuals,
1869               Unchecked_Convert_To (Base_Type (Etype (Target_Formal)),
1870                 New_Reference_To (Defining_Identifier (Formal), Loc)));
1871
1872          --  No special management required for this actual
1873
1874          else
1875             Append_To (Actuals,
1876                New_Reference_To (Defining_Identifier (Formal), Loc));
1877          end if;
1878
1879          Next_Formal (Target_Formal);
1880          Next (Formal);
1881       end loop;
1882
1883       Thunk_Id := Make_Temporary (Loc, 'T');
1884       Set_Is_Thunk (Thunk_Id);
1885       Set_Convention (Thunk_Id, Convention (Prim));
1886
1887       --  Procedure case
1888
1889       if Ekind (Target) = E_Procedure then
1890          Thunk_Code :=
1891            Make_Subprogram_Body (Loc,
1892               Specification =>
1893                 Make_Procedure_Specification (Loc,
1894                   Defining_Unit_Name       => Thunk_Id,
1895                   Parameter_Specifications => Formals),
1896               Declarations => Decl,
1897               Handled_Statement_Sequence =>
1898                 Make_Handled_Sequence_Of_Statements (Loc,
1899                   Statements => New_List (
1900                     Make_Procedure_Call_Statement (Loc,
1901                       Name => New_Occurrence_Of (Target, Loc),
1902                       Parameter_Associations => Actuals))));
1903
1904       --  Function case
1905
1906       else pragma Assert (Ekind (Target) = E_Function);
1907          Thunk_Code :=
1908            Make_Subprogram_Body (Loc,
1909               Specification =>
1910                 Make_Function_Specification (Loc,
1911                   Defining_Unit_Name       => Thunk_Id,
1912                   Parameter_Specifications => Formals,
1913                   Result_Definition =>
1914                     New_Copy (Result_Definition (Parent (Target)))),
1915               Declarations => Decl,
1916               Handled_Statement_Sequence =>
1917                 Make_Handled_Sequence_Of_Statements (Loc,
1918                   Statements => New_List (
1919                     Make_Simple_Return_Statement (Loc,
1920                       Make_Function_Call (Loc,
1921                         Name => New_Occurrence_Of (Target, Loc),
1922                         Parameter_Associations => Actuals)))));
1923       end if;
1924    end Expand_Interface_Thunk;
1925
1926    ------------------------
1927    -- Find_Specific_Type --
1928    ------------------------
1929
1930    function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
1931       Typ : Entity_Id := Root_Type (CW);
1932
1933    begin
1934       if Ekind (Typ) = E_Incomplete_Type then
1935          if From_With_Type (Typ) then
1936             Typ := Non_Limited_View (Typ);
1937          else
1938             Typ := Full_View (Typ);
1939          end if;
1940       end if;
1941
1942       return Typ;
1943    end Find_Specific_Type;
1944
1945    --------------------------
1946    -- Has_CPP_Constructors --
1947    --------------------------
1948
1949    function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
1950       E : Entity_Id;
1951
1952    begin
1953       --  Look for the constructor entities
1954
1955       E := Next_Entity (Typ);
1956       while Present (E) loop
1957          if Ekind (E) = E_Function
1958            and then Is_Constructor (E)
1959          then
1960             return True;
1961          end if;
1962
1963          Next_Entity (E);
1964       end loop;
1965
1966       return False;
1967    end Has_CPP_Constructors;
1968
1969    ------------
1970    -- Has_DT --
1971    ------------
1972
1973    function Has_DT (Typ : Entity_Id) return Boolean is
1974    begin
1975       return not Is_Interface (Typ)
1976                and then not Restriction_Active (No_Dispatching_Calls);
1977    end Has_DT;
1978
1979    ----------------------------------
1980    -- Is_Expanded_Dispatching_Call --
1981    ----------------------------------
1982
1983    function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is
1984    begin
1985       return Nkind (N) in N_Subprogram_Call
1986         and then Nkind (Name (N)) = N_Explicit_Dereference
1987         and then Is_Dispatch_Table_Entity (Etype (Name (N)));
1988    end Is_Expanded_Dispatching_Call;
1989
1990    -----------------------------------------
1991    -- Is_Predefined_Dispatching_Operation --
1992    -----------------------------------------
1993
1994    function Is_Predefined_Dispatching_Operation
1995      (E : Entity_Id) return Boolean
1996    is
1997       TSS_Name : TSS_Name_Type;
1998
1999    begin
2000       if not Is_Dispatching_Operation (E) then
2001          return False;
2002       end if;
2003
2004       Get_Name_String (Chars (E));
2005
2006       --  Most predefined primitives have internally generated names. Equality
2007       --  must be treated differently; the predefined operation is recognized
2008       --  as a homogeneous binary operator that returns Boolean.
2009
2010       if Name_Len > TSS_Name_Type'Last then
2011          TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
2012                                      .. Name_Len));
2013          if        Chars (E) = Name_uSize
2014            or else TSS_Name  = TSS_Stream_Read
2015            or else TSS_Name  = TSS_Stream_Write
2016            or else TSS_Name  = TSS_Stream_Input
2017            or else TSS_Name  = TSS_Stream_Output
2018            or else
2019              (Chars (E) = Name_Op_Eq
2020                 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
2021            or else Chars (E) = Name_uAssign
2022            or else TSS_Name  = TSS_Deep_Adjust
2023            or else TSS_Name  = TSS_Deep_Finalize
2024            or else Is_Predefined_Interface_Primitive (E)
2025          then
2026             return True;
2027          end if;
2028       end if;
2029
2030       return False;
2031    end Is_Predefined_Dispatching_Operation;
2032
2033    ---------------------------------------
2034    -- Is_Predefined_Internal_Operation  --
2035    ---------------------------------------
2036
2037    function Is_Predefined_Internal_Operation
2038      (E : Entity_Id) return Boolean
2039    is
2040       TSS_Name : TSS_Name_Type;
2041
2042    begin
2043       if not Is_Dispatching_Operation (E) then
2044          return False;
2045       end if;
2046
2047       Get_Name_String (Chars (E));
2048
2049       --  Most predefined primitives have internally generated names. Equality
2050       --  must be treated differently; the predefined operation is recognized
2051       --  as a homogeneous binary operator that returns Boolean.
2052
2053       if Name_Len > TSS_Name_Type'Last then
2054          TSS_Name :=
2055            TSS_Name_Type
2056              (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
2057
2058          if        Chars (E) = Name_uSize
2059            or else
2060              (Chars (E) = Name_Op_Eq
2061                 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
2062            or else Chars (E) = Name_uAssign
2063            or else TSS_Name  = TSS_Deep_Adjust
2064            or else TSS_Name  = TSS_Deep_Finalize
2065            or else Is_Predefined_Interface_Primitive (E)
2066          then
2067             return True;
2068          end if;
2069       end if;
2070
2071       return False;
2072    end Is_Predefined_Internal_Operation;
2073
2074    -------------------------------------
2075    -- Is_Predefined_Dispatching_Alias --
2076    -------------------------------------
2077
2078    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
2079    is
2080    begin
2081       return not Is_Predefined_Dispatching_Operation (Prim)
2082         and then Present (Alias (Prim))
2083         and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
2084    end Is_Predefined_Dispatching_Alias;
2085
2086    ---------------------------------------
2087    -- Is_Predefined_Interface_Primitive --
2088    ---------------------------------------
2089
2090    function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
2091    begin
2092       --  In VM targets we don't restrict the functionality of this test to
2093       --  compiling in Ada 2005 mode since in VM targets any tagged type has
2094       --  these primitives
2095
2096       return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
2097         and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
2098                   Chars (E) = Name_uDisp_Conditional_Select  or else
2099                   Chars (E) = Name_uDisp_Get_Prim_Op_Kind    or else
2100                   Chars (E) = Name_uDisp_Get_Task_Id         or else
2101                   Chars (E) = Name_uDisp_Requeue             or else
2102                   Chars (E) = Name_uDisp_Timed_Select);
2103    end Is_Predefined_Interface_Primitive;
2104
2105    ----------------------------------------
2106    -- Make_Disp_Asynchronous_Select_Body --
2107    ----------------------------------------
2108
2109    --  For interface types, generate:
2110
2111    --     procedure _Disp_Asynchronous_Select
2112    --       (T : in out <Typ>;
2113    --        S : Integer;
2114    --        P : System.Address;
2115    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2116    --        F : out Boolean)
2117    --     is
2118    --     begin
2119    --        F := False;
2120    --        C := Ada.Tags.POK_Function;
2121    --     end _Disp_Asynchronous_Select;
2122
2123    --  For protected types, generate:
2124
2125    --     procedure _Disp_Asynchronous_Select
2126    --       (T : in out <Typ>;
2127    --        S : Integer;
2128    --        P : System.Address;
2129    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2130    --        F : out Boolean)
2131    --     is
2132    --        I   : Integer :=
2133    --                Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2134    --        Bnn : System.Tasking.Protected_Objects.Operations.
2135    --                Communication_Block;
2136    --     begin
2137    --        System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2138    --          (T._object'Access,
2139    --           System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2140    --           P,
2141    --           System.Tasking.Asynchronous_Call,
2142    --           Bnn);
2143    --        B := System.Storage_Elements.Dummy_Communication_Block (Bnn);
2144    --     end _Disp_Asynchronous_Select;
2145
2146    --  For task types, generate:
2147
2148    --     procedure _Disp_Asynchronous_Select
2149    --       (T : in out <Typ>;
2150    --        S : Integer;
2151    --        P : System.Address;
2152    --        B : out System.Storage_Elements.Dummy_Communication_Block;
2153    --        F : out Boolean)
2154    --     is
2155    --        I   : Integer :=
2156    --                Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2157    --     begin
2158    --        System.Tasking.Rendezvous.Task_Entry_Call
2159    --          (T._task_id,
2160    --           System.Tasking.Task_Entry_Index (I),
2161    --           P,
2162    --           System.Tasking.Asynchronous_Call,
2163    --           F);
2164    --     end _Disp_Asynchronous_Select;
2165
2166    function Make_Disp_Asynchronous_Select_Body
2167      (Typ : Entity_Id) return Node_Id
2168    is
2169       Com_Block : Entity_Id;
2170       Conc_Typ  : Entity_Id           := Empty;
2171       Decls     : constant List_Id    := New_List;
2172       Loc       : constant Source_Ptr := Sloc (Typ);
2173       Obj_Ref   : Node_Id;
2174       Stmts     : constant List_Id    := New_List;
2175       Tag_Node  : Node_Id;
2176
2177    begin
2178       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2179
2180       --  Null body is generated for interface types
2181
2182       if Is_Interface (Typ) then
2183          return
2184            Make_Subprogram_Body (Loc,
2185              Specification => Make_Disp_Asynchronous_Select_Spec (Typ),
2186              Declarations  => New_List,
2187              Handled_Statement_Sequence =>
2188                Make_Handled_Sequence_Of_Statements (Loc,
2189                  New_List (Make_Assignment_Statement (Loc,
2190                    Name       => Make_Identifier (Loc, Name_uF),
2191                    Expression => New_Reference_To (Standard_False, Loc)))));
2192       end if;
2193
2194       if Is_Concurrent_Record_Type (Typ) then
2195          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2196
2197          --  Generate:
2198          --    I : Integer :=
2199          --          Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2200
2201          --  where I will be used to capture the entry index of the primitive
2202          --  wrapper at position S.
2203
2204          if Tagged_Type_Expansion then
2205             Tag_Node :=
2206               Unchecked_Convert_To (RTE (RE_Tag),
2207                 New_Reference_To
2208                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2209          else
2210             Tag_Node :=
2211               Make_Attribute_Reference (Loc,
2212                 Prefix => New_Reference_To (Typ, Loc),
2213                 Attribute_Name => Name_Tag);
2214          end if;
2215
2216          Append_To (Decls,
2217            Make_Object_Declaration (Loc,
2218              Defining_Identifier =>
2219                Make_Defining_Identifier (Loc, Name_uI),
2220              Object_Definition =>
2221                New_Reference_To (Standard_Integer, Loc),
2222              Expression =>
2223                Make_Function_Call (Loc,
2224                  Name =>
2225                    New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2226                  Parameter_Associations =>
2227                    New_List (
2228                      Tag_Node,
2229                      Make_Identifier (Loc, Name_uS)))));
2230
2231          if Ekind (Conc_Typ) = E_Protected_Type then
2232
2233             --  Generate:
2234             --    Bnn : Communication_Block;
2235
2236             Com_Block := Make_Temporary (Loc, 'B');
2237             Append_To (Decls,
2238               Make_Object_Declaration (Loc,
2239                 Defining_Identifier =>
2240                   Com_Block,
2241                 Object_Definition =>
2242                   New_Reference_To (RTE (RE_Communication_Block), Loc)));
2243
2244             --  Build T._object'Access for calls below
2245
2246             Obj_Ref :=
2247                Make_Attribute_Reference (Loc,
2248                  Attribute_Name => Name_Unchecked_Access,
2249                  Prefix         =>
2250                    Make_Selected_Component (Loc,
2251                      Prefix        => Make_Identifier (Loc, Name_uT),
2252                      Selector_Name => Make_Identifier (Loc, Name_uObject)));
2253
2254             case Corresponding_Runtime_Package (Conc_Typ) is
2255                when System_Tasking_Protected_Objects_Entries =>
2256
2257                   --  Generate:
2258                   --    Protected_Entry_Call
2259                   --      (T._object'Access,            --  Object
2260                   --       Protected_Entry_Index! (I),  --  E
2261                   --       P,                           --  Uninterpreted_Data
2262                   --       Asynchronous_Call,           --  Mode
2263                   --       Bnn);                        --  Communication_Block
2264
2265                   --  where T is the protected object, I is the entry index, P
2266                   --  is the wrapped parameters and B is the name of the
2267                   --  communication block.
2268
2269                   Append_To (Stmts,
2270                     Make_Procedure_Call_Statement (Loc,
2271                       Name =>
2272                         New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2273                       Parameter_Associations =>
2274                         New_List (
2275                           Obj_Ref,
2276
2277                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
2278                             Subtype_Mark =>
2279                               New_Reference_To
2280                                 (RTE (RE_Protected_Entry_Index), Loc),
2281                             Expression => Make_Identifier (Loc, Name_uI)),
2282
2283                           Make_Identifier (Loc, Name_uP), --  parameter block
2284                           New_Reference_To                --  Asynchronous_Call
2285                             (RTE (RE_Asynchronous_Call), Loc),
2286
2287                           New_Reference_To (Com_Block, Loc)))); -- comm block
2288
2289                when System_Tasking_Protected_Objects_Single_Entry =>
2290
2291                   --  Generate:
2292                   --    procedure Protected_Single_Entry_Call
2293                   --      (Object              : Protection_Entry_Access;
2294                   --       Uninterpreted_Data  : System.Address;
2295                   --       Mode                : Call_Modes);
2296
2297                   Append_To (Stmts,
2298                     Make_Procedure_Call_Statement (Loc,
2299                       Name =>
2300                         New_Reference_To
2301                           (RTE (RE_Protected_Single_Entry_Call), Loc),
2302                       Parameter_Associations =>
2303                         New_List (
2304                           Obj_Ref,
2305
2306                           Make_Attribute_Reference (Loc,
2307                             Prefix         => Make_Identifier (Loc, Name_uP),
2308                             Attribute_Name => Name_Address),
2309
2310                             New_Reference_To
2311                              (RTE (RE_Asynchronous_Call), Loc))));
2312
2313                when others =>
2314                   raise Program_Error;
2315             end case;
2316
2317             --  Generate:
2318             --    B := Dummy_Communication_Block (Bnn);
2319
2320             Append_To (Stmts,
2321               Make_Assignment_Statement (Loc,
2322                 Name => Make_Identifier (Loc, Name_uB),
2323                 Expression =>
2324                   Make_Unchecked_Type_Conversion (Loc,
2325                     Subtype_Mark =>
2326                       New_Reference_To (
2327                         RTE (RE_Dummy_Communication_Block), Loc),
2328                     Expression =>
2329                       New_Reference_To (Com_Block, Loc))));
2330
2331             --  Generate:
2332             --    F := False;
2333
2334             Append_To (Stmts,
2335               Make_Assignment_Statement (Loc,
2336                 Name       => Make_Identifier (Loc, Name_uF),
2337                 Expression => New_Reference_To (Standard_False, Loc)));
2338
2339          else
2340             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2341
2342             --  Generate:
2343             --    Task_Entry_Call
2344             --      (T._task_id,             --  Acceptor
2345             --       Task_Entry_Index! (I),  --  E
2346             --       P,                      --  Uninterpreted_Data
2347             --       Asynchronous_Call,      --  Mode
2348             --       F);                     --  Rendezvous_Successful
2349
2350             --  where T is the task object, I is the entry index, P is the
2351             --  wrapped parameters and F is the status flag.
2352
2353             Append_To (Stmts,
2354               Make_Procedure_Call_Statement (Loc,
2355                 Name =>
2356                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2357                 Parameter_Associations =>
2358                   New_List (
2359                     Make_Selected_Component (Loc,         -- T._task_id
2360                       Prefix        => Make_Identifier (Loc, Name_uT),
2361                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2362
2363                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2364                       Subtype_Mark =>
2365                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2366                       Expression => Make_Identifier (Loc, Name_uI)),
2367
2368                     Make_Identifier (Loc, Name_uP),       --  parameter block
2369                     New_Reference_To                      --  Asynchronous_Call
2370                       (RTE (RE_Asynchronous_Call), Loc),
2371                     Make_Identifier (Loc, Name_uF))));    --  status flag
2372          end if;
2373
2374       else
2375          --  Ensure that the statements list is non-empty
2376
2377          Append_To (Stmts,
2378            Make_Assignment_Statement (Loc,
2379              Name       => Make_Identifier (Loc, Name_uF),
2380              Expression => New_Reference_To (Standard_False, Loc)));
2381       end if;
2382
2383       return
2384         Make_Subprogram_Body (Loc,
2385           Specification              =>
2386             Make_Disp_Asynchronous_Select_Spec (Typ),
2387           Declarations               => Decls,
2388           Handled_Statement_Sequence =>
2389             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2390    end Make_Disp_Asynchronous_Select_Body;
2391
2392    ----------------------------------------
2393    -- Make_Disp_Asynchronous_Select_Spec --
2394    ----------------------------------------
2395
2396    function Make_Disp_Asynchronous_Select_Spec
2397      (Typ : Entity_Id) return Node_Id
2398    is
2399       Loc    : constant Source_Ptr := Sloc (Typ);
2400       Def_Id : constant Node_Id    :=
2401                  Make_Defining_Identifier (Loc,
2402                    Name_uDisp_Asynchronous_Select);
2403       Params : constant List_Id    := New_List;
2404
2405    begin
2406       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2407
2408       --  T : in out Typ;                     --  Object parameter
2409       --  S : Integer;                        --  Primitive operation slot
2410       --  P : Address;                        --  Wrapped parameters
2411       --  B : out Dummy_Communication_Block;  --  Communication block dummy
2412       --  F : out Boolean;                    --  Status flag
2413
2414       Append_List_To (Params, New_List (
2415
2416         Make_Parameter_Specification (Loc,
2417           Defining_Identifier =>
2418             Make_Defining_Identifier (Loc, Name_uT),
2419           Parameter_Type =>
2420             New_Reference_To (Typ, Loc),
2421           In_Present  => True,
2422           Out_Present => True),
2423
2424         Make_Parameter_Specification (Loc,
2425           Defining_Identifier =>
2426             Make_Defining_Identifier (Loc, Name_uS),
2427           Parameter_Type =>
2428             New_Reference_To (Standard_Integer, Loc)),
2429
2430         Make_Parameter_Specification (Loc,
2431           Defining_Identifier =>
2432             Make_Defining_Identifier (Loc, Name_uP),
2433           Parameter_Type =>
2434             New_Reference_To (RTE (RE_Address), Loc)),
2435
2436         Make_Parameter_Specification (Loc,
2437           Defining_Identifier =>
2438             Make_Defining_Identifier (Loc, Name_uB),
2439           Parameter_Type =>
2440             New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc),
2441           Out_Present => True),
2442
2443         Make_Parameter_Specification (Loc,
2444           Defining_Identifier =>
2445             Make_Defining_Identifier (Loc, Name_uF),
2446           Parameter_Type =>
2447             New_Reference_To (Standard_Boolean, Loc),
2448           Out_Present => True)));
2449
2450       return
2451         Make_Procedure_Specification (Loc,
2452           Defining_Unit_Name       => Def_Id,
2453           Parameter_Specifications => Params);
2454    end Make_Disp_Asynchronous_Select_Spec;
2455
2456    ---------------------------------------
2457    -- Make_Disp_Conditional_Select_Body --
2458    ---------------------------------------
2459
2460    --  For interface types, generate:
2461
2462    --     procedure _Disp_Conditional_Select
2463    --       (T : in out <Typ>;
2464    --        S : Integer;
2465    --        P : System.Address;
2466    --        C : out Ada.Tags.Prim_Op_Kind;
2467    --        F : out Boolean)
2468    --     is
2469    --     begin
2470    --        F := False;
2471    --        C := Ada.Tags.POK_Function;
2472    --     end _Disp_Conditional_Select;
2473
2474    --  For protected types, generate:
2475
2476    --     procedure _Disp_Conditional_Select
2477    --       (T : in out <Typ>;
2478    --        S : Integer;
2479    --        P : System.Address;
2480    --        C : out Ada.Tags.Prim_Op_Kind;
2481    --        F : out Boolean)
2482    --     is
2483    --        I   : Integer;
2484    --        Bnn : System.Tasking.Protected_Objects.Operations.
2485    --                Communication_Block;
2486
2487    --     begin
2488    --        C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP, S));
2489
2490    --        if C = Ada.Tags.POK_Procedure
2491    --          or else C = Ada.Tags.POK_Protected_Procedure
2492    --          or else C = Ada.Tags.POK_Task_Procedure
2493    --        then
2494    --           F := True;
2495    --           return;
2496    --        end if;
2497
2498    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2499    --        System.Tasking.Protected_Objects.Operations.Protected_Entry_Call
2500    --          (T.object'Access,
2501    --           System.Tasking.Protected_Objects.Protected_Entry_Index (I),
2502    --           P,
2503    --           System.Tasking.Conditional_Call,
2504    --           Bnn);
2505    --        F := not Cancelled (Bnn);
2506    --     end _Disp_Conditional_Select;
2507
2508    --  For task types, generate:
2509
2510    --     procedure _Disp_Conditional_Select
2511    --       (T : in out <Typ>;
2512    --        S : Integer;
2513    --        P : System.Address;
2514    --        C : out Ada.Tags.Prim_Op_Kind;
2515    --        F : out Boolean)
2516    --     is
2517    --        I : Integer;
2518
2519    --     begin
2520    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP, S));
2521    --        System.Tasking.Rendezvous.Task_Entry_Call
2522    --          (T._task_id,
2523    --           System.Tasking.Task_Entry_Index (I),
2524    --           P,
2525    --           System.Tasking.Conditional_Call,
2526    --           F);
2527    --     end _Disp_Conditional_Select;
2528
2529    function Make_Disp_Conditional_Select_Body
2530      (Typ : Entity_Id) return Node_Id
2531    is
2532       Loc      : constant Source_Ptr := Sloc (Typ);
2533       Blk_Nam  : Entity_Id;
2534       Conc_Typ : Entity_Id           := Empty;
2535       Decls    : constant List_Id    := New_List;
2536       Obj_Ref  : Node_Id;
2537       Stmts    : constant List_Id    := New_List;
2538       Tag_Node : Node_Id;
2539
2540    begin
2541       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2542
2543       --  Null body is generated for interface types
2544
2545       if Is_Interface (Typ) then
2546          return
2547            Make_Subprogram_Body (Loc,
2548              Specification =>
2549                Make_Disp_Conditional_Select_Spec (Typ),
2550              Declarations =>
2551                No_List,
2552              Handled_Statement_Sequence =>
2553                Make_Handled_Sequence_Of_Statements (Loc,
2554                  New_List (Make_Assignment_Statement (Loc,
2555                    Name       => Make_Identifier (Loc, Name_uF),
2556                    Expression => New_Reference_To (Standard_False, Loc)))));
2557       end if;
2558
2559       if Is_Concurrent_Record_Type (Typ) then
2560          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2561
2562          --  Generate:
2563          --    I : Integer;
2564
2565          --  where I will be used to capture the entry index of the primitive
2566          --  wrapper at position S.
2567
2568          Append_To (Decls,
2569            Make_Object_Declaration (Loc,
2570              Defining_Identifier =>
2571                Make_Defining_Identifier (Loc, Name_uI),
2572              Object_Definition =>
2573                New_Reference_To (Standard_Integer, Loc)));
2574
2575          --  Generate:
2576          --    C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag! (<type>VP), S);
2577
2578          --    if C = POK_Procedure
2579          --      or else C = POK_Protected_Procedure
2580          --      or else C = POK_Task_Procedure;
2581          --    then
2582          --       F := True;
2583          --       return;
2584          --    end if;
2585
2586          Build_Common_Dispatching_Select_Statements (Typ, Stmts);
2587
2588          --  Generate:
2589          --    Bnn : Communication_Block;
2590
2591          --  where Bnn is the name of the communication block used in the
2592          --  call to Protected_Entry_Call.
2593
2594          Blk_Nam := Make_Temporary (Loc, 'B');
2595          Append_To (Decls,
2596            Make_Object_Declaration (Loc,
2597              Defining_Identifier =>
2598                Blk_Nam,
2599              Object_Definition =>
2600                New_Reference_To (RTE (RE_Communication_Block), Loc)));
2601
2602          --  Generate:
2603          --    I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag! (<type>VP), S);
2604
2605          --  I is the entry index and S is the dispatch table slot
2606
2607          if Tagged_Type_Expansion then
2608             Tag_Node :=
2609               Unchecked_Convert_To (RTE (RE_Tag),
2610                 New_Reference_To
2611                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2612
2613          else
2614             Tag_Node :=
2615               Make_Attribute_Reference (Loc,
2616                 Prefix => New_Reference_To (Typ, Loc),
2617                 Attribute_Name => Name_Tag);
2618          end if;
2619
2620          Append_To (Stmts,
2621            Make_Assignment_Statement (Loc,
2622              Name => Make_Identifier (Loc, Name_uI),
2623              Expression =>
2624                Make_Function_Call (Loc,
2625                  Name =>
2626                    New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2627                  Parameter_Associations =>
2628                    New_List (
2629                      Tag_Node,
2630                      Make_Identifier (Loc, Name_uS)))));
2631
2632          if Ekind (Conc_Typ) = E_Protected_Type then
2633
2634             Obj_Ref :=                                  -- T._object'Access
2635                Make_Attribute_Reference (Loc,
2636                  Attribute_Name => Name_Unchecked_Access,
2637                  Prefix         =>
2638                    Make_Selected_Component (Loc,
2639                      Prefix        => Make_Identifier (Loc, Name_uT),
2640                      Selector_Name => Make_Identifier (Loc, Name_uObject)));
2641
2642             case Corresponding_Runtime_Package (Conc_Typ) is
2643                when System_Tasking_Protected_Objects_Entries =>
2644                   --  Generate:
2645
2646                   --    Protected_Entry_Call
2647                   --      (T._object'Access,            --  Object
2648                   --       Protected_Entry_Index! (I),  --  E
2649                   --       P,                           --  Uninterpreted_Data
2650                   --       Conditional_Call,            --  Mode
2651                   --       Bnn);                        --  Block
2652
2653                   --  where T is the protected object, I is the entry index, P
2654                   --  are the wrapped parameters and Bnn is the name of the
2655                   --  communication block.
2656
2657                   Append_To (Stmts,
2658                     Make_Procedure_Call_Statement (Loc,
2659                       Name =>
2660                         New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
2661                       Parameter_Associations =>
2662                         New_List (
2663                           Obj_Ref,
2664
2665                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
2666                             Subtype_Mark =>
2667                               New_Reference_To
2668                                  (RTE (RE_Protected_Entry_Index), Loc),
2669                             Expression => Make_Identifier (Loc, Name_uI)),
2670
2671                           Make_Identifier (Loc, Name_uP),  --  parameter block
2672
2673                           New_Reference_To (               --  Conditional_Call
2674                             RTE (RE_Conditional_Call), Loc),
2675                           New_Reference_To (               --  Bnn
2676                             Blk_Nam, Loc))));
2677
2678                when System_Tasking_Protected_Objects_Single_Entry =>
2679
2680                   --    If we are compiling for a restricted run-time, the call
2681                   --    uses the simpler form.
2682
2683                   Append_To (Stmts,
2684                     Make_Procedure_Call_Statement (Loc,
2685                       Name =>
2686                         New_Reference_To
2687                           (RTE (RE_Protected_Single_Entry_Call), Loc),
2688                       Parameter_Associations =>
2689                         New_List (
2690                           Obj_Ref,
2691
2692                           Make_Attribute_Reference (Loc,
2693                             Prefix         => Make_Identifier (Loc, Name_uP),
2694                             Attribute_Name => Name_Address),
2695
2696                             New_Reference_To
2697                              (RTE (RE_Conditional_Call), Loc))));
2698                when others =>
2699                   raise Program_Error;
2700             end case;
2701
2702             --  Generate:
2703             --    F := not Cancelled (Bnn);
2704
2705             --  where F is the success flag. The status of Cancelled is negated
2706             --  in order to match the behaviour of the version for task types.
2707
2708             Append_To (Stmts,
2709               Make_Assignment_Statement (Loc,
2710                 Name       => Make_Identifier (Loc, Name_uF),
2711                 Expression =>
2712                   Make_Op_Not (Loc,
2713                     Right_Opnd =>
2714                       Make_Function_Call (Loc,
2715                         Name =>
2716                           New_Reference_To (RTE (RE_Cancelled), Loc),
2717                         Parameter_Associations =>
2718                           New_List (
2719                             New_Reference_To (Blk_Nam, Loc))))));
2720          else
2721             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2722
2723             --  Generate:
2724             --    Task_Entry_Call
2725             --      (T._task_id,             --  Acceptor
2726             --       Task_Entry_Index! (I),  --  E
2727             --       P,                      --  Uninterpreted_Data
2728             --       Conditional_Call,       --  Mode
2729             --       F);                     --  Rendezvous_Successful
2730
2731             --  where T is the task object, I is the entry index, P are the
2732             --  wrapped parameters and F is the status flag.
2733
2734             Append_To (Stmts,
2735               Make_Procedure_Call_Statement (Loc,
2736                 Name =>
2737                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
2738                 Parameter_Associations =>
2739                   New_List (
2740
2741                     Make_Selected_Component (Loc,         -- T._task_id
2742                       Prefix        => Make_Identifier (Loc, Name_uT),
2743                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
2744
2745                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2746                       Subtype_Mark =>
2747                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2748                       Expression   => Make_Identifier (Loc, Name_uI)),
2749
2750                     Make_Identifier (Loc, Name_uP),       --  parameter block
2751                     New_Reference_To                      --  Conditional_Call
2752                       (RTE (RE_Conditional_Call), Loc),
2753                     Make_Identifier (Loc, Name_uF))));    --  status flag
2754          end if;
2755
2756       else
2757          --  Initialize out parameters
2758
2759          Append_To (Stmts,
2760            Make_Assignment_Statement (Loc,
2761              Name       => Make_Identifier (Loc, Name_uF),
2762              Expression => New_Reference_To (Standard_False, Loc)));
2763          Append_To (Stmts,
2764            Make_Assignment_Statement (Loc,
2765              Name       => Make_Identifier (Loc, Name_uC),
2766              Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
2767       end if;
2768
2769       return
2770         Make_Subprogram_Body (Loc,
2771           Specification              =>
2772             Make_Disp_Conditional_Select_Spec (Typ),
2773           Declarations               => Decls,
2774           Handled_Statement_Sequence =>
2775             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2776    end Make_Disp_Conditional_Select_Body;
2777
2778    ---------------------------------------
2779    -- Make_Disp_Conditional_Select_Spec --
2780    ---------------------------------------
2781
2782    function Make_Disp_Conditional_Select_Spec
2783      (Typ : Entity_Id) return Node_Id
2784    is
2785       Loc    : constant Source_Ptr := Sloc (Typ);
2786       Def_Id : constant Node_Id    :=
2787                  Make_Defining_Identifier (Loc,
2788                    Name_uDisp_Conditional_Select);
2789       Params : constant List_Id    := New_List;
2790
2791    begin
2792       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2793
2794       --  T : in out Typ;        --  Object parameter
2795       --  S : Integer;           --  Primitive operation slot
2796       --  P : Address;           --  Wrapped parameters
2797       --  C : out Prim_Op_Kind;  --  Call kind
2798       --  F : out Boolean;       --  Status flag
2799
2800       Append_List_To (Params, New_List (
2801
2802         Make_Parameter_Specification (Loc,
2803           Defining_Identifier =>
2804             Make_Defining_Identifier (Loc, Name_uT),
2805           Parameter_Type =>
2806             New_Reference_To (Typ, Loc),
2807           In_Present  => True,
2808           Out_Present => True),
2809
2810         Make_Parameter_Specification (Loc,
2811           Defining_Identifier =>
2812             Make_Defining_Identifier (Loc, Name_uS),
2813           Parameter_Type =>
2814             New_Reference_To (Standard_Integer, Loc)),
2815
2816         Make_Parameter_Specification (Loc,
2817           Defining_Identifier =>
2818             Make_Defining_Identifier (Loc, Name_uP),
2819           Parameter_Type =>
2820             New_Reference_To (RTE (RE_Address), Loc)),
2821
2822         Make_Parameter_Specification (Loc,
2823           Defining_Identifier =>
2824             Make_Defining_Identifier (Loc, Name_uC),
2825           Parameter_Type =>
2826             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2827           Out_Present => True),
2828
2829         Make_Parameter_Specification (Loc,
2830           Defining_Identifier =>
2831             Make_Defining_Identifier (Loc, Name_uF),
2832           Parameter_Type =>
2833             New_Reference_To (Standard_Boolean, Loc),
2834           Out_Present => True)));
2835
2836       return
2837         Make_Procedure_Specification (Loc,
2838           Defining_Unit_Name       => Def_Id,
2839           Parameter_Specifications => Params);
2840    end Make_Disp_Conditional_Select_Spec;
2841
2842    -------------------------------------
2843    -- Make_Disp_Get_Prim_Op_Kind_Body --
2844    -------------------------------------
2845
2846    function Make_Disp_Get_Prim_Op_Kind_Body
2847      (Typ : Entity_Id) return Node_Id
2848    is
2849       Loc      : constant Source_Ptr := Sloc (Typ);
2850       Tag_Node : Node_Id;
2851
2852    begin
2853       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2854
2855       if Is_Interface (Typ) then
2856          return
2857            Make_Subprogram_Body (Loc,
2858              Specification =>
2859                Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2860              Declarations =>
2861                New_List,
2862              Handled_Statement_Sequence =>
2863                Make_Handled_Sequence_Of_Statements (Loc,
2864                  New_List (Make_Null_Statement (Loc))));
2865       end if;
2866
2867       --  Generate:
2868       --    C := get_prim_op_kind (tag! (<type>VP), S);
2869
2870       --  where C is the out parameter capturing the call kind and S is the
2871       --  dispatch table slot number.
2872
2873       if Tagged_Type_Expansion then
2874          Tag_Node :=
2875            Unchecked_Convert_To (RTE (RE_Tag),
2876              New_Reference_To
2877               (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
2878
2879       else
2880          Tag_Node :=
2881            Make_Attribute_Reference (Loc,
2882              Prefix => New_Reference_To (Typ, Loc),
2883              Attribute_Name => Name_Tag);
2884       end if;
2885
2886       return
2887         Make_Subprogram_Body (Loc,
2888           Specification =>
2889             Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
2890           Declarations =>
2891             New_List,
2892           Handled_Statement_Sequence =>
2893             Make_Handled_Sequence_Of_Statements (Loc,
2894               New_List (
2895                 Make_Assignment_Statement (Loc,
2896                   Name =>
2897                     Make_Identifier (Loc, Name_uC),
2898                   Expression =>
2899                     Make_Function_Call (Loc,
2900                       Name =>
2901                         New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
2902                       Parameter_Associations => New_List (
2903                         Tag_Node,
2904                         Make_Identifier (Loc, Name_uS)))))));
2905    end Make_Disp_Get_Prim_Op_Kind_Body;
2906
2907    -------------------------------------
2908    -- Make_Disp_Get_Prim_Op_Kind_Spec --
2909    -------------------------------------
2910
2911    function Make_Disp_Get_Prim_Op_Kind_Spec
2912      (Typ : Entity_Id) return Node_Id
2913    is
2914       Loc    : constant Source_Ptr := Sloc (Typ);
2915       Def_Id : constant Node_Id    :=
2916                  Make_Defining_Identifier (Loc,
2917                    Name_uDisp_Get_Prim_Op_Kind);
2918       Params : constant List_Id    := New_List;
2919
2920    begin
2921       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2922
2923       --  T : in out Typ;       --  Object parameter
2924       --  S : Integer;          --  Primitive operation slot
2925       --  C : out Prim_Op_Kind; --  Call kind
2926
2927       Append_List_To (Params, New_List (
2928
2929         Make_Parameter_Specification (Loc,
2930           Defining_Identifier =>
2931             Make_Defining_Identifier (Loc, Name_uT),
2932           Parameter_Type =>
2933             New_Reference_To (Typ, Loc),
2934           In_Present  => True,
2935           Out_Present => True),
2936
2937         Make_Parameter_Specification (Loc,
2938           Defining_Identifier =>
2939             Make_Defining_Identifier (Loc, Name_uS),
2940           Parameter_Type =>
2941             New_Reference_To (Standard_Integer, Loc)),
2942
2943         Make_Parameter_Specification (Loc,
2944           Defining_Identifier =>
2945             Make_Defining_Identifier (Loc, Name_uC),
2946           Parameter_Type =>
2947             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2948           Out_Present => True)));
2949
2950       return
2951         Make_Procedure_Specification (Loc,
2952            Defining_Unit_Name       => Def_Id,
2953            Parameter_Specifications => Params);
2954    end Make_Disp_Get_Prim_Op_Kind_Spec;
2955
2956    --------------------------------
2957    -- Make_Disp_Get_Task_Id_Body --
2958    --------------------------------
2959
2960    function Make_Disp_Get_Task_Id_Body
2961      (Typ : Entity_Id) return Node_Id
2962    is
2963       Loc : constant Source_Ptr := Sloc (Typ);
2964       Ret : Node_Id;
2965
2966    begin
2967       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2968
2969       if Is_Concurrent_Record_Type (Typ)
2970         and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
2971       then
2972          --  Generate:
2973          --    return To_Address (_T._task_id);
2974
2975          Ret :=
2976            Make_Simple_Return_Statement (Loc,
2977              Expression =>
2978                Make_Unchecked_Type_Conversion (Loc,
2979                  Subtype_Mark =>
2980                    New_Reference_To (RTE (RE_Address), Loc),
2981                  Expression =>
2982                    Make_Selected_Component (Loc,
2983                      Prefix        => Make_Identifier (Loc, Name_uT),
2984                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id))));
2985
2986       --  A null body is constructed for non-task types
2987
2988       else
2989          --  Generate:
2990          --    return Null_Address;
2991
2992          Ret :=
2993            Make_Simple_Return_Statement (Loc,
2994              Expression =>
2995                New_Reference_To (RTE (RE_Null_Address), Loc));
2996       end if;
2997
2998       return
2999         Make_Subprogram_Body (Loc,
3000           Specification =>
3001             Make_Disp_Get_Task_Id_Spec (Typ),
3002           Declarations =>
3003             New_List,
3004           Handled_Statement_Sequence =>
3005             Make_Handled_Sequence_Of_Statements (Loc,
3006               New_List (Ret)));
3007    end Make_Disp_Get_Task_Id_Body;
3008
3009    --------------------------------
3010    -- Make_Disp_Get_Task_Id_Spec --
3011    --------------------------------
3012
3013    function Make_Disp_Get_Task_Id_Spec
3014      (Typ : Entity_Id) return Node_Id
3015    is
3016       Loc : constant Source_Ptr := Sloc (Typ);
3017
3018    begin
3019       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3020
3021       return
3022         Make_Function_Specification (Loc,
3023           Defining_Unit_Name =>
3024             Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
3025           Parameter_Specifications => New_List (
3026             Make_Parameter_Specification (Loc,
3027               Defining_Identifier =>
3028                 Make_Defining_Identifier (Loc, Name_uT),
3029               Parameter_Type =>
3030                 New_Reference_To (Typ, Loc))),
3031           Result_Definition =>
3032             New_Reference_To (RTE (RE_Address), Loc));
3033    end Make_Disp_Get_Task_Id_Spec;
3034
3035    ----------------------------
3036    -- Make_Disp_Requeue_Body --
3037    ----------------------------
3038
3039    function Make_Disp_Requeue_Body
3040      (Typ : Entity_Id) return Node_Id
3041    is
3042       Loc      : constant Source_Ptr := Sloc (Typ);
3043       Conc_Typ : Entity_Id           := Empty;
3044       Stmts    : constant List_Id    := New_List;
3045
3046    begin
3047       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3048
3049       --  Null body is generated for interface types and non-concurrent
3050       --  tagged types.
3051
3052       if Is_Interface (Typ)
3053         or else not Is_Concurrent_Record_Type (Typ)
3054       then
3055          return
3056            Make_Subprogram_Body (Loc,
3057              Specification =>
3058                Make_Disp_Requeue_Spec (Typ),
3059              Declarations =>
3060                No_List,
3061              Handled_Statement_Sequence =>
3062                Make_Handled_Sequence_Of_Statements (Loc,
3063                  New_List (Make_Null_Statement (Loc))));
3064       end if;
3065
3066       Conc_Typ := Corresponding_Concurrent_Type (Typ);
3067
3068       if Ekind (Conc_Typ) = E_Protected_Type then
3069
3070          --  Generate statements:
3071          --    if F then
3072          --       System.Tasking.Protected_Objects.Operations.
3073          --         Requeue_Protected_Entry
3074          --           (Protection_Entries_Access (P),
3075          --            O._object'Unchecked_Access,
3076          --            Protected_Entry_Index (I),
3077          --            A);
3078          --    else
3079          --       System.Tasking.Protected_Objects.Operations.
3080          --         Requeue_Task_To_Protected_Entry
3081          --           (O._object'Unchecked_Access,
3082          --            Protected_Entry_Index (I),
3083          --            A);
3084          --    end if;
3085
3086          if Restriction_Active (No_Entry_Queue) then
3087             Append_To (Stmts, Make_Null_Statement (Loc));
3088          else
3089             Append_To (Stmts,
3090               Make_If_Statement (Loc,
3091                 Condition       => Make_Identifier (Loc, Name_uF),
3092
3093                 Then_Statements =>
3094                   New_List (
3095
3096                      --  Call to Requeue_Protected_Entry
3097
3098                     Make_Procedure_Call_Statement (Loc,
3099                       Name =>
3100                         New_Reference_To (
3101                           RTE (RE_Requeue_Protected_Entry), Loc),
3102                       Parameter_Associations =>
3103                         New_List (
3104
3105                           Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
3106                             Subtype_Mark =>
3107                               New_Reference_To (
3108                                 RTE (RE_Protection_Entries_Access), Loc),
3109                             Expression =>
3110                               Make_Identifier (Loc, Name_uP)),
3111
3112                           Make_Attribute_Reference (Loc,      -- O._object'Acc
3113                             Attribute_Name =>
3114                               Name_Unchecked_Access,
3115                             Prefix =>
3116                               Make_Selected_Component (Loc,
3117                                 Prefix        =>
3118                                   Make_Identifier (Loc, Name_uO),
3119                                 Selector_Name =>
3120                                   Make_Identifier (Loc, Name_uObject))),
3121
3122                           Make_Unchecked_Type_Conversion (Loc,  -- entry index
3123                             Subtype_Mark =>
3124                               New_Reference_To (
3125                                 RTE (RE_Protected_Entry_Index), Loc),
3126                             Expression => Make_Identifier (Loc, Name_uI)),
3127
3128                           Make_Identifier (Loc, Name_uA)))),   -- abort status
3129
3130                 Else_Statements =>
3131                   New_List (
3132
3133                      --  Call to Requeue_Task_To_Protected_Entry
3134
3135                     Make_Procedure_Call_Statement (Loc,
3136                       Name =>
3137                         New_Reference_To (
3138                           RTE (RE_Requeue_Task_To_Protected_Entry), Loc),
3139                       Parameter_Associations =>
3140                         New_List (
3141
3142                           Make_Attribute_Reference (Loc,     -- O._object'Acc
3143                             Attribute_Name =>
3144                               Name_Unchecked_Access,
3145                             Prefix =>
3146                               Make_Selected_Component (Loc,
3147                                 Prefix =>
3148                                   Make_Identifier (Loc, Name_uO),
3149                                 Selector_Name =>
3150                                   Make_Identifier (Loc, Name_uObject))),
3151
3152                           Make_Unchecked_Type_Conversion (Loc, -- entry index
3153                             Subtype_Mark =>
3154                               New_Reference_To (
3155                                 RTE (RE_Protected_Entry_Index), Loc),
3156                             Expression =>
3157                               Make_Identifier (Loc, Name_uI)),
3158
3159                           Make_Identifier (Loc, Name_uA)))))); -- abort status
3160          end if;
3161       else
3162          pragma Assert (Is_Task_Type (Conc_Typ));
3163
3164          --  Generate:
3165          --    if F then
3166          --       System.Tasking.Rendezvous.Requeue_Protected_To_Task_Entry
3167          --         (Protection_Entries_Access (P),
3168          --          O._task_id,
3169          --          Task_Entry_Index (I),
3170          --          A);
3171          --    else
3172          --       System.Tasking.Rendezvous.Requeue_Task_Entry
3173          --         (O._task_id,
3174          --          Task_Entry_Index (I),
3175          --          A);
3176          --    end if;
3177
3178          Append_To (Stmts,
3179            Make_If_Statement (Loc,
3180              Condition       => Make_Identifier (Loc, Name_uF),
3181
3182              Then_Statements => New_List (
3183
3184                --  Call to Requeue_Protected_To_Task_Entry
3185
3186                Make_Procedure_Call_Statement (Loc,
3187                  Name =>
3188                    New_Reference_To
3189                      (RTE (RE_Requeue_Protected_To_Task_Entry), Loc),
3190
3191                  Parameter_Associations => New_List (
3192
3193                    Make_Unchecked_Type_Conversion (Loc,  -- PEA (P)
3194                      Subtype_Mark =>
3195                        New_Reference_To
3196                          (RTE (RE_Protection_Entries_Access), Loc),
3197                           Expression => Make_Identifier (Loc, Name_uP)),
3198
3199                    Make_Selected_Component (Loc,         -- O._task_id
3200                      Prefix        => Make_Identifier (Loc, Name_uO),
3201                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3202
3203                    Make_Unchecked_Type_Conversion (Loc,  -- entry index
3204                      Subtype_Mark =>
3205                        New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3206                      Expression   => Make_Identifier (Loc, Name_uI)),
3207
3208                    Make_Identifier (Loc, Name_uA)))),    -- abort status
3209
3210              Else_Statements => New_List (
3211
3212                --  Call to Requeue_Task_Entry
3213
3214                Make_Procedure_Call_Statement (Loc,
3215                  Name => New_Reference_To (RTE (RE_Requeue_Task_Entry), Loc),
3216
3217                  Parameter_Associations => New_List (
3218
3219                    Make_Selected_Component (Loc,         -- O._task_id
3220                      Prefix        => Make_Identifier (Loc, Name_uO),
3221                      Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3222
3223                    Make_Unchecked_Type_Conversion (Loc,  -- entry index
3224                      Subtype_Mark =>
3225                        New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3226                      Expression   => Make_Identifier (Loc, Name_uI)),
3227
3228                    Make_Identifier (Loc, Name_uA))))));  -- abort status
3229       end if;
3230
3231       --  Even though no declarations are needed in both cases, we allocate
3232       --  a list for entities added by Freeze.
3233
3234       return
3235         Make_Subprogram_Body (Loc,
3236           Specification =>
3237             Make_Disp_Requeue_Spec (Typ),
3238           Declarations =>
3239             New_List,
3240           Handled_Statement_Sequence =>
3241             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3242    end Make_Disp_Requeue_Body;
3243
3244    ----------------------------
3245    -- Make_Disp_Requeue_Spec --
3246    ----------------------------
3247
3248    function Make_Disp_Requeue_Spec
3249      (Typ : Entity_Id) return Node_Id
3250    is
3251       Loc : constant Source_Ptr := Sloc (Typ);
3252
3253    begin
3254       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3255
3256       --  O : in out Typ;   -  Object parameter
3257       --  F : Boolean;      -  Protected (True) / task (False) flag
3258       --  P : Address;      -  Protection_Entries_Access value
3259       --  I : Entry_Index   -  Index of entry call
3260       --  A : Boolean       -  Abort flag
3261
3262       --  Note that the Protection_Entries_Access value is represented as a
3263       --  System.Address in order to avoid dragging in the tasking runtime
3264       --  when compiling sources without tasking constructs.
3265
3266       return
3267         Make_Procedure_Specification (Loc,
3268           Defining_Unit_Name =>
3269             Make_Defining_Identifier (Loc, Name_uDisp_Requeue),
3270
3271           Parameter_Specifications =>
3272             New_List (
3273
3274               Make_Parameter_Specification (Loc,             --  O
3275                 Defining_Identifier =>
3276                   Make_Defining_Identifier (Loc, Name_uO),
3277                 Parameter_Type =>
3278                   New_Reference_To (Typ, Loc),
3279                 In_Present  => True,
3280                 Out_Present => True),
3281
3282               Make_Parameter_Specification (Loc,             --  F
3283                 Defining_Identifier =>
3284                   Make_Defining_Identifier (Loc, Name_uF),
3285                 Parameter_Type =>
3286                   New_Reference_To (Standard_Boolean, Loc)),
3287
3288               Make_Parameter_Specification (Loc,             --  P
3289                 Defining_Identifier =>
3290                   Make_Defining_Identifier (Loc, Name_uP),
3291                 Parameter_Type =>
3292                   New_Reference_To (RTE (RE_Address), Loc)),
3293
3294               Make_Parameter_Specification (Loc,             --  I
3295                 Defining_Identifier =>
3296                   Make_Defining_Identifier (Loc, Name_uI),
3297                 Parameter_Type =>
3298                   New_Reference_To (Standard_Integer, Loc)),
3299
3300               Make_Parameter_Specification (Loc,             --  A
3301                 Defining_Identifier =>
3302                   Make_Defining_Identifier (Loc, Name_uA),
3303                 Parameter_Type =>
3304                   New_Reference_To (Standard_Boolean, Loc))));
3305    end Make_Disp_Requeue_Spec;
3306
3307    ---------------------------------
3308    -- Make_Disp_Timed_Select_Body --
3309    ---------------------------------
3310
3311    --  For interface types, generate:
3312
3313    --     procedure _Disp_Timed_Select
3314    --       (T : in out <Typ>;
3315    --        S : Integer;
3316    --        P : System.Address;
3317    --        D : Duration;
3318    --        M : Integer;
3319    --        C : out Ada.Tags.Prim_Op_Kind;
3320    --        F : out Boolean)
3321    --     is
3322    --     begin
3323    --        F := False;
3324    --        C := Ada.Tags.POK_Function;
3325    --     end _Disp_Timed_Select;
3326
3327    --  For protected types, generate:
3328
3329    --     procedure _Disp_Timed_Select
3330    --       (T : in out <Typ>;
3331    --        S : Integer;
3332    --        P : System.Address;
3333    --        D : Duration;
3334    --        M : Integer;
3335    --        C : out Ada.Tags.Prim_Op_Kind;
3336    --        F : out Boolean)
3337    --     is
3338    --        I : Integer;
3339
3340    --     begin
3341    --        C := Ada.Tags.Get_Prim_Op_Kind (Ada.Tags.Tag (<Typ>VP), S);
3342
3343    --        if C = Ada.Tags.POK_Procedure
3344    --          or else C = Ada.Tags.POK_Protected_Procedure
3345    --          or else C = Ada.Tags.POK_Task_Procedure
3346    --        then
3347    --           F := True;
3348    --           return;
3349    --        end if;
3350
3351    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3352    --        System.Tasking.Protected_Objects.Operations.
3353    --          Timed_Protected_Entry_Call
3354    --            (T._object'Access,
3355    --             System.Tasking.Protected_Objects.Protected_Entry_Index (I),
3356    --             P,
3357    --             D,
3358    --             M,
3359    --             F);
3360    --     end _Disp_Timed_Select;
3361
3362    --  For task types, generate:
3363
3364    --     procedure _Disp_Timed_Select
3365    --       (T : in out <Typ>;
3366    --        S : Integer;
3367    --        P : System.Address;
3368    --        D : Duration;
3369    --        M : Integer;
3370    --        C : out Ada.Tags.Prim_Op_Kind;
3371    --        F : out Boolean)
3372    --     is
3373    --        I : Integer;
3374
3375    --     begin
3376    --        I := Ada.Tags.Get_Entry_Index (Ada.Tags.Tag (<Typ>VP), S);
3377    --        System.Tasking.Rendezvous.Timed_Task_Entry_Call
3378    --          (T._task_id,
3379    --           System.Tasking.Task_Entry_Index (I),
3380    --           P,
3381    --           D,
3382    --           M,
3383    --           F);
3384    --     end _Disp_Time_Select;
3385
3386    function Make_Disp_Timed_Select_Body
3387      (Typ : Entity_Id) return Node_Id
3388    is
3389       Loc      : constant Source_Ptr := Sloc (Typ);
3390       Conc_Typ : Entity_Id           := Empty;
3391       Decls    : constant List_Id    := New_List;
3392       Obj_Ref  : Node_Id;
3393       Stmts    : constant List_Id    := New_List;
3394       Tag_Node : Node_Id;
3395
3396    begin
3397       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3398
3399       --  Null body is generated for interface types
3400
3401       if Is_Interface (Typ) then
3402          return
3403            Make_Subprogram_Body (Loc,
3404              Specification =>
3405                Make_Disp_Timed_Select_Spec (Typ),
3406              Declarations =>
3407                New_List,
3408              Handled_Statement_Sequence =>
3409                Make_Handled_Sequence_Of_Statements (Loc,
3410                  New_List (
3411                    Make_Assignment_Statement (Loc,
3412                      Name       => Make_Identifier (Loc, Name_uF),
3413                      Expression => New_Reference_To (Standard_False, Loc)))));
3414       end if;
3415
3416       if Is_Concurrent_Record_Type (Typ) then
3417          Conc_Typ := Corresponding_Concurrent_Type (Typ);
3418
3419          --  Generate:
3420          --    I : Integer;
3421
3422          --  where I will be used to capture the entry index of the primitive
3423          --  wrapper at position S.
3424
3425          Append_To (Decls,
3426            Make_Object_Declaration (Loc,
3427              Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
3428              Object_Definition   => New_Reference_To (Standard_Integer, Loc)));
3429
3430          --  Generate:
3431          --    C := Get_Prim_Op_Kind (tag! (<type>VP), S);
3432
3433          --    if C = POK_Procedure
3434          --      or else C = POK_Protected_Procedure
3435          --      or else C = POK_Task_Procedure;
3436          --    then
3437          --       F := True;
3438          --       return;
3439          --    end if;
3440
3441          Build_Common_Dispatching_Select_Statements (Typ, Stmts);
3442
3443          --  Generate:
3444          --    I := Get_Entry_Index (tag! (<type>VP), S);
3445
3446          --  I is the entry index and S is the dispatch table slot
3447
3448          if Tagged_Type_Expansion then
3449             Tag_Node :=
3450               Unchecked_Convert_To (RTE (RE_Tag),
3451                 New_Reference_To
3452                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
3453
3454          else
3455             Tag_Node :=
3456               Make_Attribute_Reference (Loc,
3457                 Prefix         => New_Reference_To (Typ, Loc),
3458                 Attribute_Name => Name_Tag);
3459          end if;
3460
3461          Append_To (Stmts,
3462            Make_Assignment_Statement (Loc,
3463              Name       => Make_Identifier (Loc, Name_uI),
3464              Expression =>
3465                Make_Function_Call (Loc,
3466                  Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
3467                  Parameter_Associations =>
3468                    New_List (
3469                      Tag_Node,
3470                      Make_Identifier (Loc, Name_uS)))));
3471
3472          --  Protected case
3473
3474          if Ekind (Conc_Typ) = E_Protected_Type then
3475
3476             --  Build T._object'Access
3477
3478             Obj_Ref :=
3479                Make_Attribute_Reference (Loc,
3480                   Attribute_Name => Name_Unchecked_Access,
3481                   Prefix         =>
3482                     Make_Selected_Component (Loc,
3483                       Prefix        => Make_Identifier (Loc, Name_uT),
3484                       Selector_Name => Make_Identifier (Loc, Name_uObject)));
3485
3486             --  Normal case, No_Entry_Queue restriction not active. In this
3487             --  case we generate:
3488
3489             --   Timed_Protected_Entry_Call
3490             --     (T._object'access,
3491             --      Protected_Entry_Index! (I),
3492             --      P, D, M, F);
3493
3494             --  where T is the protected object, I is the entry index, P are
3495             --  the wrapped parameters, D is the delay amount, M is the delay
3496             --  mode and F is the status flag.
3497
3498             case Corresponding_Runtime_Package (Conc_Typ) is
3499                when System_Tasking_Protected_Objects_Entries =>
3500                   Append_To (Stmts,
3501                     Make_Procedure_Call_Statement (Loc,
3502                       Name =>
3503                         New_Reference_To
3504                           (RTE (RE_Timed_Protected_Entry_Call), Loc),
3505                       Parameter_Associations =>
3506                         New_List (
3507                           Obj_Ref,
3508
3509                           Make_Unchecked_Type_Conversion (Loc,  --  entry index
3510                             Subtype_Mark =>
3511                               New_Reference_To
3512                                 (RTE (RE_Protected_Entry_Index), Loc),
3513                             Expression =>
3514                               Make_Identifier (Loc, Name_uI)),
3515
3516                           Make_Identifier (Loc, Name_uP),   --  parameter block
3517                           Make_Identifier (Loc, Name_uD),   --  delay
3518                           Make_Identifier (Loc, Name_uM),   --  delay mode
3519                           Make_Identifier (Loc, Name_uF)))); --  status flag
3520
3521                when System_Tasking_Protected_Objects_Single_Entry =>
3522                   --  Generate:
3523
3524                   --   Timed_Protected_Single_Entry_Call
3525                   --     (T._object'access, P, D, M, F);
3526
3527                   --  where T is the protected object, P is the wrapped
3528                   --  parameters, D is the delay amount, M is the delay mode, F
3529                   --  is the status flag.
3530
3531                   Append_To (Stmts,
3532                     Make_Procedure_Call_Statement (Loc,
3533                       Name =>
3534                         New_Reference_To
3535                           (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
3536                       Parameter_Associations =>
3537                         New_List (
3538                           Obj_Ref,
3539                           Make_Identifier (Loc, Name_uP),   --  parameter block
3540                           Make_Identifier (Loc, Name_uD),   --  delay
3541                           Make_Identifier (Loc, Name_uM),   --  delay mode
3542                           Make_Identifier (Loc, Name_uF)))); --  status flag
3543
3544                when others =>
3545                   raise Program_Error;
3546             end case;
3547
3548          --  Task case
3549
3550          else
3551             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
3552
3553             --  Generate:
3554             --    Timed_Task_Entry_Call (
3555             --      T._task_id,
3556             --      Task_Entry_Index! (I),
3557             --      P,
3558             --      D,
3559             --      M,
3560             --      F);
3561
3562             --  where T is the task object, I is the entry index, P are the
3563             --  wrapped parameters, D is the delay amount, M is the delay
3564             --  mode and F is the status flag.
3565
3566             Append_To (Stmts,
3567               Make_Procedure_Call_Statement (Loc,
3568                 Name =>
3569                   New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
3570                 Parameter_Associations =>
3571                   New_List (
3572
3573                     Make_Selected_Component (Loc,         --  T._task_id
3574                       Prefix        => Make_Identifier (Loc, Name_uT),
3575                       Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
3576
3577                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
3578                       Subtype_Mark =>
3579                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
3580                       Expression   => Make_Identifier (Loc, Name_uI)),
3581
3582                     Make_Identifier (Loc, Name_uP),       --  parameter block
3583                     Make_Identifier (Loc, Name_uD),       --  delay
3584                     Make_Identifier (Loc, Name_uM),       --  delay mode
3585                     Make_Identifier (Loc, Name_uF))));    --  status flag
3586          end if;
3587
3588       else
3589          --  Initialize out parameters
3590
3591          Append_To (Stmts,
3592            Make_Assignment_Statement (Loc,
3593              Name       => Make_Identifier (Loc, Name_uF),
3594              Expression => New_Reference_To (Standard_False, Loc)));
3595          Append_To (Stmts,
3596            Make_Assignment_Statement (Loc,
3597              Name       => Make_Identifier (Loc, Name_uC),
3598              Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
3599       end if;
3600
3601       return
3602         Make_Subprogram_Body (Loc,
3603           Specification              => Make_Disp_Timed_Select_Spec (Typ),
3604           Declarations               => Decls,
3605           Handled_Statement_Sequence =>
3606             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
3607    end Make_Disp_Timed_Select_Body;
3608
3609    ---------------------------------
3610    -- Make_Disp_Timed_Select_Spec --
3611    ---------------------------------
3612
3613    function Make_Disp_Timed_Select_Spec
3614      (Typ : Entity_Id) return Node_Id
3615    is
3616       Loc    : constant Source_Ptr := Sloc (Typ);
3617       Def_Id : constant Node_Id    :=
3618                  Make_Defining_Identifier (Loc,
3619                    Name_uDisp_Timed_Select);
3620       Params : constant List_Id    := New_List;
3621
3622    begin
3623       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
3624
3625       --  T : in out Typ;        --  Object parameter
3626       --  S : Integer;           --  Primitive operation slot
3627       --  P : Address;           --  Wrapped parameters
3628       --  D : Duration;          --  Delay
3629       --  M : Integer;           --  Delay Mode
3630       --  C : out Prim_Op_Kind;  --  Call kind
3631       --  F : out Boolean;       --  Status flag
3632
3633       Append_List_To (Params, New_List (
3634
3635         Make_Parameter_Specification (Loc,
3636           Defining_Identifier =>
3637             Make_Defining_Identifier (Loc, Name_uT),
3638           Parameter_Type =>
3639             New_Reference_To (Typ, Loc),
3640           In_Present  => True,
3641           Out_Present => True),
3642
3643         Make_Parameter_Specification (Loc,
3644           Defining_Identifier =>
3645             Make_Defining_Identifier (Loc, Name_uS),
3646           Parameter_Type =>
3647             New_Reference_To (Standard_Integer, Loc)),
3648
3649         Make_Parameter_Specification (Loc,
3650           Defining_Identifier =>
3651             Make_Defining_Identifier (Loc, Name_uP),
3652           Parameter_Type =>
3653             New_Reference_To (RTE (RE_Address), Loc)),
3654
3655         Make_Parameter_Specification (Loc,
3656           Defining_Identifier =>
3657             Make_Defining_Identifier (Loc, Name_uD),
3658           Parameter_Type =>
3659             New_Reference_To (Standard_Duration, Loc)),
3660
3661         Make_Parameter_Specification (Loc,
3662           Defining_Identifier =>
3663             Make_Defining_Identifier (Loc, Name_uM),
3664           Parameter_Type =>
3665             New_Reference_To (Standard_Integer, Loc)),
3666
3667         Make_Parameter_Specification (Loc,
3668           Defining_Identifier =>
3669             Make_Defining_Identifier (Loc, Name_uC),
3670           Parameter_Type =>
3671             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
3672           Out_Present => True)));
3673
3674       Append_To (Params,
3675         Make_Parameter_Specification (Loc,
3676           Defining_Identifier =>
3677             Make_Defining_Identifier (Loc, Name_uF),
3678           Parameter_Type =>
3679             New_Reference_To (Standard_Boolean, Loc),
3680           Out_Present => True));
3681
3682       return
3683         Make_Procedure_Specification (Loc,
3684           Defining_Unit_Name       => Def_Id,
3685           Parameter_Specifications => Params);
3686    end Make_Disp_Timed_Select_Spec;
3687
3688    -------------
3689    -- Make_DT --
3690    -------------
3691
3692    --  The frontend supports two models for expanding dispatch tables
3693    --  associated with library-level defined tagged types: statically
3694    --  and non-statically allocated dispatch tables. In the former case
3695    --  the object containing the dispatch table is constant and it is
3696    --  initialized by means of a positional aggregate. In the latter case,
3697    --  the object containing the dispatch table is a variable which is
3698    --  initialized by means of assignments.
3699
3700    --  In case of locally defined tagged types, the object containing the
3701    --  object containing the dispatch table is always a variable (instead
3702    --  of a constant). This is currently required to give support to late
3703    --  overriding of primitives. For example:
3704
3705    --     procedure Example is
3706    --        package Pkg is
3707    --           type T1 is tagged null record;
3708    --           procedure Prim (O : T1);
3709    --        end Pkg;
3710
3711    --        type T2 is new Pkg.T1 with null record;
3712    --        procedure Prim (X : T2) is    -- late overriding
3713    --        begin
3714    --           ...
3715    --     ...
3716    --     end;
3717
3718    function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
3719       Loc : constant Source_Ptr := Sloc (Typ);
3720
3721       Max_Predef_Prims : constant Int :=
3722                            UI_To_Int
3723                              (Intval
3724                                (Expression
3725                                  (Parent (RTE (RE_Max_Predef_Prims)))));
3726
3727       DT_Decl : constant Elist_Id := New_Elmt_List;
3728       DT_Aggr : constant Elist_Id := New_Elmt_List;
3729       --  Entities marked with attribute Is_Dispatch_Table_Entity
3730
3731       procedure Check_Premature_Freezing
3732         (Subp        : Entity_Id;
3733          Tagged_Type : Entity_Id;
3734          Typ         : Entity_Id);
3735       --  Verify that all non-tagged types in the profile of a subprogram
3736       --  are frozen at the point the subprogram is frozen. This enforces
3737       --  the rule on RM 13.14 (14) as modified by AI05-019. At the point a
3738       --  subprogram is frozen, enough must be known about it to build the
3739       --  activation record for it, which requires at least that the size of
3740       --  all parameters be known. Controlling arguments are by-reference,
3741       --  and therefore the rule only applies to non-tagged types.
3742       --  Typical violation of the rule involves an object declaration that
3743       --  freezes a tagged type, when one of its primitive operations has a
3744       --  type in its profile whose full view has not been analyzed yet.
3745       --  More complex cases involve composite types that have one private
3746       --  unfrozen subcomponent.
3747
3748       procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0);
3749       --  Export the dispatch table DT of tagged type Typ. Required to generate
3750       --  forward references and statically allocate the table. For primary
3751       --  dispatch tables Index is 0; for secondary dispatch tables the value
3752       --  of index must match the Suffix_Index value assigned to the table by
3753       --  Make_Tags when generating its unique external name, and it is used to
3754       --  retrieve from the Dispatch_Table_Wrappers list associated with Typ
3755       --  the external name generated by Import_DT.
3756
3757       procedure Make_Secondary_DT
3758         (Typ              : Entity_Id;
3759          Iface            : Entity_Id;
3760          Suffix_Index     : Int;
3761          Num_Iface_Prims  : Nat;
3762          Iface_DT_Ptr     : Entity_Id;
3763          Predef_Prims_Ptr : Entity_Id;
3764          Build_Thunks     : Boolean;
3765          Result           : List_Id);
3766       --  Ada 2005 (AI-251): Expand the declarations for a Secondary Dispatch
3767       --  Table of Typ associated with Iface. Each abstract interface of Typ
3768       --  has two secondary dispatch tables: one containing pointers to thunks
3769       --  and another containing pointers to the primitives covering the
3770       --  interface primitives. The former secondary table is generated when
3771       --  Build_Thunks is True, and provides common support for dispatching
3772       --  calls through interface types; the latter secondary table is
3773       --  generated when Build_Thunks is False, and provides support for
3774       --  Generic Dispatching Constructors that dispatch calls through
3775       --  interface types. When constructing this latter table the value of
3776       --  Suffix_Index is -1 to indicate that there is no need to export such
3777       --  table when building statically allocated dispatch tables; a positive
3778       --  value of Suffix_Index must match the Suffix_Index value assigned to
3779       --  this secondary dispatch table by Make_Tags when its unique external
3780       --  name was generated.
3781
3782       ------------------------------
3783       -- Check_Premature_Freezing --
3784       ------------------------------
3785
3786       procedure Check_Premature_Freezing
3787         (Subp        : Entity_Id;
3788          Tagged_Type : Entity_Id;
3789          Typ         : Entity_Id)
3790       is
3791          Comp : Entity_Id;
3792
3793          function Is_Actual_For_Formal_Incomplete_Type
3794            (T : Entity_Id) return Boolean;
3795          --  In Ada 2012, if a nested generic has an incomplete formal type,
3796          --  the actual may be (and usually is) a private type whose completion
3797          --  appears later. It is safe to build the dispatch table in this
3798          --  case, gigi will have full views available.
3799
3800          ------------------------------------------
3801          -- Is_Actual_For_Formal_Incomplete_Type --
3802          ------------------------------------------
3803
3804          function Is_Actual_For_Formal_Incomplete_Type
3805            (T : Entity_Id) return Boolean
3806          is
3807             Gen_Par : Entity_Id;
3808             F       : Node_Id;
3809
3810          begin
3811             if not Is_Generic_Instance (Current_Scope)
3812               or else not Used_As_Generic_Actual (T)
3813             then
3814                return False;
3815
3816             else
3817                Gen_Par := Generic_Parent (Parent (Current_Scope));
3818             end if;
3819
3820             F :=
3821               First
3822                 (Generic_Formal_Declarations
3823                      (Unit_Declaration_Node (Gen_Par)));
3824             while Present (F) loop
3825                if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
3826                   return True;
3827                end if;
3828
3829                Next (F);
3830             end loop;
3831
3832             return False;
3833          end Is_Actual_For_Formal_Incomplete_Type;
3834
3835       --  Start of processing for Check_Premature_Freezing
3836
3837       begin
3838          --  Note that if the type is a (subtype of) a generic actual, the
3839          --  actual will have been frozen by the instantiation.
3840
3841          if Present (N)
3842            and then Is_Private_Type (Typ)
3843            and then No (Full_View (Typ))
3844            and then not Is_Generic_Type (Typ)
3845            and then not Is_Tagged_Type (Typ)
3846            and then not Is_Frozen (Typ)
3847            and then not Is_Generic_Actual_Type (Typ)
3848          then
3849             Error_Msg_Sloc := Sloc (Subp);
3850             Error_Msg_NE
3851               ("declaration must appear after completion of type &", N, Typ);
3852             Error_Msg_NE
3853               ("\which is an untagged type in the profile of"
3854                & " primitive operation & declared#", N, Subp);
3855
3856          else
3857             Comp := Private_Component (Typ);
3858
3859             if not Is_Tagged_Type (Typ)
3860               and then Present (Comp)
3861               and then not Is_Frozen (Comp)
3862               and then
3863                 not Is_Actual_For_Formal_Incomplete_Type (Comp)
3864             then
3865                Error_Msg_Sloc := Sloc (Subp);
3866                Error_Msg_Node_2 := Subp;
3867                Error_Msg_Name_1 := Chars (Tagged_Type);
3868                Error_Msg_NE
3869                  ("declaration must appear after completion of type &",
3870                    N, Comp);
3871                Error_Msg_NE
3872                  ("\which is a component of untagged type& in the profile of"
3873                & " primitive & of type % that is frozen by the declaration ",
3874                    N, Typ);
3875             end if;
3876          end if;
3877       end Check_Premature_Freezing;
3878
3879       ---------------
3880       -- Export_DT --
3881       ---------------
3882
3883       procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0)
3884       is
3885          Count : Nat;
3886          Elmt  : Elmt_Id;
3887
3888       begin
3889          Set_Is_Statically_Allocated (DT);
3890          Set_Is_True_Constant (DT);
3891          Set_Is_Exported (DT);
3892
3893          Count := 0;
3894          Elmt  := First_Elmt (Dispatch_Table_Wrappers (Typ));
3895          while Count /= Index loop
3896             Next_Elmt (Elmt);
3897             Count := Count + 1;
3898          end loop;
3899
3900          pragma Assert (Related_Type (Node (Elmt)) = Typ);
3901
3902          Get_External_Name
3903            (Entity     => Node (Elmt),
3904             Has_Suffix => True);
3905
3906          Set_Interface_Name (DT,
3907            Make_String_Literal (Loc,
3908              Strval => String_From_Name_Buffer));
3909
3910          --  Ensure proper Sprint output of this implicit importation
3911
3912          Set_Is_Internal (DT);
3913          Set_Is_Public (DT);
3914       end Export_DT;
3915
3916       -----------------------
3917       -- Make_Secondary_DT --
3918       -----------------------
3919
3920       procedure Make_Secondary_DT
3921         (Typ              : Entity_Id;
3922          Iface            : Entity_Id;
3923          Suffix_Index     : Int;
3924          Num_Iface_Prims  : Nat;
3925          Iface_DT_Ptr     : Entity_Id;
3926          Predef_Prims_Ptr : Entity_Id;
3927          Build_Thunks     : Boolean;
3928          Result           : List_Id)
3929       is
3930          Loc                : constant Source_Ptr := Sloc (Typ);
3931          Exporting_Table    : constant Boolean :=
3932                                 Building_Static_DT (Typ)
3933                                   and then Suffix_Index > 0;
3934          Iface_DT           : constant Entity_Id := Make_Temporary (Loc, 'T');
3935          Predef_Prims       : constant Entity_Id := Make_Temporary (Loc, 'R');
3936          DT_Constr_List     : List_Id;
3937          DT_Aggr_List       : List_Id;
3938          Empty_DT           : Boolean := False;
3939          Nb_Predef_Prims    : Nat := 0;
3940          Nb_Prim            : Nat;
3941          New_Node           : Node_Id;
3942          OSD                : Entity_Id;
3943          OSD_Aggr_List      : List_Id;
3944          Pos                : Nat;
3945          Prim               : Entity_Id;
3946          Prim_Elmt          : Elmt_Id;
3947          Prim_Ops_Aggr_List : List_Id;
3948
3949       begin
3950          --  Handle cases in which we do not generate statically allocated
3951          --  dispatch tables.
3952
3953          if not Building_Static_DT (Typ) then
3954             Set_Ekind (Predef_Prims, E_Variable);
3955             Set_Ekind (Iface_DT, E_Variable);
3956
3957          --  Statically allocated dispatch tables and related entities are
3958          --  constants.
3959
3960          else
3961             Set_Ekind (Predef_Prims, E_Constant);
3962             Set_Is_Statically_Allocated (Predef_Prims);
3963             Set_Is_True_Constant (Predef_Prims);
3964
3965             Set_Ekind (Iface_DT, E_Constant);
3966             Set_Is_Statically_Allocated (Iface_DT);
3967             Set_Is_True_Constant (Iface_DT);
3968          end if;
3969
3970          --  Calculate the number of slots of the dispatch table. If the number
3971          --  of primitives of Typ is 0 we reserve a dummy single entry for its
3972          --  DT because at run time the pointer to this dummy entry will be
3973          --  used as the tag.
3974
3975          if Num_Iface_Prims = 0 then
3976             Empty_DT := True;
3977             Nb_Prim  := 1;
3978          else
3979             Nb_Prim  := Num_Iface_Prims;
3980          end if;
3981
3982          --  Generate:
3983
3984          --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3985          --                    (predef-prim-op-thunk-1'address,
3986          --                     predef-prim-op-thunk-2'address,
3987          --                     ...
3988          --                     predef-prim-op-thunk-n'address);
3989          --   for Predef_Prims'Alignment use Address'Alignment
3990
3991          --  Stage 1: Calculate the number of predefined primitives
3992
3993          if not Building_Static_DT (Typ) then
3994             Nb_Predef_Prims := Max_Predef_Prims;
3995          else
3996             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3997             while Present (Prim_Elmt) loop
3998                Prim := Node (Prim_Elmt);
3999
4000                if Is_Predefined_Dispatching_Operation (Prim)
4001                  and then not Is_Abstract_Subprogram (Prim)
4002                then
4003                   Pos := UI_To_Int (DT_Position (Prim));
4004
4005                   if Pos > Nb_Predef_Prims then
4006                      Nb_Predef_Prims := Pos;
4007                   end if;
4008                end if;
4009
4010                Next_Elmt (Prim_Elmt);
4011             end loop;
4012          end if;
4013
4014          --  Stage 2: Create the thunks associated with the predefined
4015          --  primitives and save their entity to fill the aggregate.
4016
4017          declare
4018             Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
4019             Decl       : Node_Id;
4020             Thunk_Id   : Entity_Id;
4021             Thunk_Code : Node_Id;
4022
4023          begin
4024             Prim_Ops_Aggr_List := New_List;
4025             Prim_Table := (others => Empty);
4026
4027             if Building_Static_DT (Typ) then
4028                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4029                while Present (Prim_Elmt) loop
4030                   Prim := Node (Prim_Elmt);
4031
4032                   if Is_Predefined_Dispatching_Operation (Prim)
4033                     and then not Is_Abstract_Subprogram (Prim)
4034                     and then not Is_Eliminated (Prim)
4035                     and then not Present (Prim_Table
4036                                            (UI_To_Int (DT_Position (Prim))))
4037                   then
4038                      if not Build_Thunks then
4039                         Prim_Table (UI_To_Int (DT_Position (Prim))) :=
4040                           Alias (Prim);
4041
4042                      else
4043                         Expand_Interface_Thunk
4044                           (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
4045
4046                         if Present (Thunk_Id) then
4047                            Append_To (Result, Thunk_Code);
4048                            Prim_Table (UI_To_Int (DT_Position (Prim)))
4049                              := Thunk_Id;
4050                         end if;
4051                      end if;
4052                   end if;
4053
4054                   Next_Elmt (Prim_Elmt);
4055                end loop;
4056             end if;
4057
4058             for J in Prim_Table'Range loop
4059                if Present (Prim_Table (J)) then
4060                   New_Node :=
4061                     Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4062                       Make_Attribute_Reference (Loc,
4063                         Prefix => New_Reference_To (Prim_Table (J), Loc),
4064                         Attribute_Name => Name_Unrestricted_Access));
4065                else
4066                   New_Node := Make_Null (Loc);
4067                end if;
4068
4069                Append_To (Prim_Ops_Aggr_List, New_Node);
4070             end loop;
4071
4072             New_Node :=
4073               Make_Aggregate (Loc,
4074                 Expressions => Prim_Ops_Aggr_List);
4075
4076             --  Remember aggregates initializing dispatch tables
4077
4078             Append_Elmt (New_Node, DT_Aggr);
4079
4080             Decl :=
4081               Make_Subtype_Declaration (Loc,
4082                 Defining_Identifier => Make_Temporary (Loc, 'S'),
4083                 Subtype_Indication  =>
4084                   New_Reference_To (RTE (RE_Address_Array), Loc));
4085
4086             Append_To (Result, Decl);
4087
4088             Append_To (Result,
4089               Make_Object_Declaration (Loc,
4090                 Defining_Identifier => Predef_Prims,
4091                 Constant_Present    => Building_Static_DT (Typ),
4092                 Aliased_Present     => True,
4093                 Object_Definition   => New_Reference_To
4094                                          (Defining_Identifier (Decl), Loc),
4095                 Expression => New_Node));
4096
4097             Append_To (Result,
4098               Make_Attribute_Definition_Clause (Loc,
4099                 Name       => New_Reference_To (Predef_Prims, Loc),
4100                 Chars      => Name_Alignment,
4101                 Expression =>
4102                   Make_Attribute_Reference (Loc,
4103                     Prefix =>
4104                       New_Reference_To (RTE (RE_Integer_Address), Loc),
4105                     Attribute_Name => Name_Alignment)));
4106          end;
4107
4108          --  Generate
4109
4110          --   OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4111          --          (OSD_Table => (1 => <value>,
4112          --                           ...
4113          --                         N => <value>));
4114
4115          --   Iface_DT : Dispatch_Table (Nb_Prims) :=
4116          --               ([ Signature   => <sig-value> ],
4117          --                Tag_Kind      => <tag_kind-value>,
4118          --                Predef_Prims  => Predef_Prims'Address,
4119          --                Offset_To_Top => 0,
4120          --                OSD           => OSD'Address,
4121          --                Prims_Ptr     => (prim-op-1'address,
4122          --                                  prim-op-2'address,
4123          --                                  ...
4124          --                                  prim-op-n'address));
4125          --   for Iface_DT'Alignment use Address'Alignment;
4126
4127          --  Stage 3: Initialize the discriminant and the record components
4128
4129          DT_Constr_List := New_List;
4130          DT_Aggr_List   := New_List;
4131
4132          --  Nb_Prim
4133
4134          Append_To (DT_Constr_List, Make_Integer_Literal (Loc, Nb_Prim));
4135          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, Nb_Prim));
4136
4137          --  Signature
4138
4139          if RTE_Record_Component_Available (RE_Signature) then
4140             Append_To (DT_Aggr_List,
4141               New_Reference_To (RTE (RE_Secondary_DT), Loc));
4142          end if;
4143
4144          --  Tag_Kind
4145
4146          if RTE_Record_Component_Available (RE_Tag_Kind) then
4147             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
4148          end if;
4149
4150          --  Predef_Prims
4151
4152          Append_To (DT_Aggr_List,
4153            Make_Attribute_Reference (Loc,
4154              Prefix => New_Reference_To (Predef_Prims, Loc),
4155              Attribute_Name => Name_Address));
4156
4157          --  Note: The correct value of Offset_To_Top will be set by the init
4158          --  subprogram
4159
4160          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4161
4162          --  Generate the Object Specific Data table required to dispatch calls
4163          --  through synchronized interfaces.
4164
4165          if Empty_DT
4166            or else Is_Abstract_Type (Typ)
4167            or else Is_Controlled (Typ)
4168            or else Restriction_Active (No_Dispatching_Calls)
4169            or else not Is_Limited_Type (Typ)
4170            or else not Has_Interfaces (Typ)
4171            or else not Build_Thunks
4172            or else not RTE_Record_Component_Available (RE_OSD_Table)
4173          then
4174             --  No OSD table required
4175
4176             Append_To (DT_Aggr_List,
4177               New_Reference_To (RTE (RE_Null_Address), Loc));
4178
4179          else
4180             OSD_Aggr_List := New_List;
4181
4182             declare
4183                Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4184                Prim       : Entity_Id;
4185                Prim_Alias : Entity_Id;
4186                Prim_Elmt  : Elmt_Id;
4187                E          : Entity_Id;
4188                Count      : Nat := 0;
4189                Pos        : Nat;
4190
4191             begin
4192                Prim_Table := (others => Empty);
4193                Prim_Alias := Empty;
4194
4195                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4196                while Present (Prim_Elmt) loop
4197                   Prim := Node (Prim_Elmt);
4198
4199                   if Present (Interface_Alias (Prim))
4200                     and then Find_Dispatching_Type
4201                                (Interface_Alias (Prim)) = Iface
4202                   then
4203                      Prim_Alias := Interface_Alias (Prim);
4204                      E   := Ultimate_Alias (Prim);
4205                      Pos := UI_To_Int (DT_Position (Prim_Alias));
4206
4207                      if Present (Prim_Table (Pos)) then
4208                         pragma Assert (Prim_Table (Pos) = E);
4209                         null;
4210
4211                      else
4212                         Prim_Table (Pos) := E;
4213
4214                         Append_To (OSD_Aggr_List,
4215                           Make_Component_Association (Loc,
4216                             Choices => New_List (
4217                               Make_Integer_Literal (Loc,
4218                                 DT_Position (Prim_Alias))),
4219                             Expression =>
4220                               Make_Integer_Literal (Loc,
4221                                 DT_Position (Alias (Prim)))));
4222
4223                         Count := Count + 1;
4224                      end if;
4225                   end if;
4226
4227                   Next_Elmt (Prim_Elmt);
4228                end loop;
4229                pragma Assert (Count = Nb_Prim);
4230             end;
4231
4232             OSD := Make_Temporary (Loc, 'I');
4233
4234             Append_To (Result,
4235               Make_Object_Declaration (Loc,
4236                 Defining_Identifier => OSD,
4237                 Object_Definition   =>
4238                   Make_Subtype_Indication (Loc,
4239                     Subtype_Mark =>
4240                       New_Reference_To (RTE (RE_Object_Specific_Data), Loc),
4241                     Constraint =>
4242                       Make_Index_Or_Discriminant_Constraint (Loc,
4243                         Constraints => New_List (
4244                           Make_Integer_Literal (Loc, Nb_Prim)))),
4245
4246                 Expression          =>
4247                   Make_Aggregate (Loc,
4248                     Component_Associations => New_List (
4249                       Make_Component_Association (Loc,
4250                         Choices => New_List (
4251                           New_Occurrence_Of
4252                             (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
4253                         Expression =>
4254                           Make_Integer_Literal (Loc, Nb_Prim)),
4255
4256                       Make_Component_Association (Loc,
4257                         Choices => New_List (
4258                           New_Occurrence_Of
4259                             (RTE_Record_Component (RE_OSD_Table), Loc)),
4260                         Expression => Make_Aggregate (Loc,
4261                           Component_Associations => OSD_Aggr_List))))));
4262
4263             Append_To (Result,
4264               Make_Attribute_Definition_Clause (Loc,
4265                 Name       => New_Reference_To (OSD, Loc),
4266                 Chars      => Name_Alignment,
4267                 Expression =>
4268                   Make_Attribute_Reference (Loc,
4269                     Prefix =>
4270                       New_Reference_To (RTE (RE_Integer_Address), Loc),
4271                     Attribute_Name => Name_Alignment)));
4272
4273             --  In secondary dispatch tables the Typeinfo component contains
4274             --  the address of the Object Specific Data (see a-tags.ads)
4275
4276             Append_To (DT_Aggr_List,
4277               Make_Attribute_Reference (Loc,
4278                 Prefix => New_Reference_To (OSD, Loc),
4279                 Attribute_Name => Name_Address));
4280          end if;
4281
4282          --  Initialize the table of primitive operations
4283
4284          Prim_Ops_Aggr_List := New_List;
4285
4286          if Empty_DT then
4287             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4288
4289          elsif Is_Abstract_Type (Typ)
4290            or else not Building_Static_DT (Typ)
4291          then
4292             for J in 1 .. Nb_Prim loop
4293                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4294             end loop;
4295
4296          else
4297             declare
4298                CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
4299                E            : Entity_Id;
4300                Prim_Pos     : Nat;
4301                Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4302                Thunk_Code   : Node_Id;
4303                Thunk_Id     : Entity_Id;
4304
4305             begin
4306                Prim_Table := (others => Empty);
4307
4308                Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
4309                while Present (Prim_Elmt) loop
4310                   Prim     := Node (Prim_Elmt);
4311                   E        := Ultimate_Alias (Prim);
4312                   Prim_Pos := UI_To_Int (DT_Position (E));
4313
4314                   --  Do not reference predefined primitives because they are
4315                   --  located in a separate dispatch table; skip abstract and
4316                   --  eliminated primitives; skip primitives located in the C++
4317                   --  part of the dispatch table because their slot is set by
4318                   --  the IC routine.
4319
4320                   if not Is_Predefined_Dispatching_Operation (Prim)
4321                     and then Present (Interface_Alias (Prim))
4322                     and then not Is_Abstract_Subprogram (Alias (Prim))
4323                     and then not Is_Eliminated (Alias (Prim))
4324                     and then (not Is_CPP_Class (Root_Type (Typ))
4325                                or else Prim_Pos > CPP_Nb_Prims)
4326                     and then Find_Dispatching_Type
4327                                (Interface_Alias (Prim)) = Iface
4328
4329                      --  Generate the code of the thunk only if the abstract
4330                      --  interface type is not an immediate ancestor of
4331                      --  Tagged_Type. Otherwise the DT associated with the
4332                      --  interface is the primary DT.
4333
4334                     and then not Is_Ancestor (Iface, Typ,
4335                                               Use_Full_View => True)
4336                   then
4337                      if not Build_Thunks then
4338                         Prim_Pos :=
4339                           UI_To_Int (DT_Position (Interface_Alias (Prim)));
4340                         Prim_Table (Prim_Pos) := Alias (Prim);
4341
4342                      else
4343                         Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
4344
4345                         if Present (Thunk_Id) then
4346                            Prim_Pos :=
4347                              UI_To_Int (DT_Position (Interface_Alias (Prim)));
4348
4349                            Prim_Table (Prim_Pos) := Thunk_Id;
4350                            Append_To (Result, Thunk_Code);
4351                         end if;
4352                      end if;
4353                   end if;
4354
4355                   Next_Elmt (Prim_Elmt);
4356                end loop;
4357
4358                for J in Prim_Table'Range loop
4359                   if Present (Prim_Table (J)) then
4360                      New_Node :=
4361                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4362                          Make_Attribute_Reference (Loc,
4363                            Prefix => New_Reference_To (Prim_Table (J), Loc),
4364                            Attribute_Name => Name_Unrestricted_Access));
4365
4366                   else
4367                      New_Node := Make_Null (Loc);
4368                   end if;
4369
4370                   Append_To (Prim_Ops_Aggr_List, New_Node);
4371                end loop;
4372             end;
4373          end if;
4374
4375          New_Node :=
4376            Make_Aggregate (Loc,
4377              Expressions => Prim_Ops_Aggr_List);
4378
4379          Append_To (DT_Aggr_List, New_Node);
4380
4381          --  Remember aggregates initializing dispatch tables
4382
4383          Append_Elmt (New_Node, DT_Aggr);
4384
4385          --  Note: Secondary dispatch tables cannot be declared constant
4386          --  because the component Offset_To_Top is currently initialized
4387          --  by the IP routine.
4388
4389          Append_To (Result,
4390            Make_Object_Declaration (Loc,
4391              Defining_Identifier => Iface_DT,
4392              Aliased_Present     => True,
4393              Constant_Present    => False,
4394
4395              Object_Definition   =>
4396                Make_Subtype_Indication (Loc,
4397                  Subtype_Mark => New_Reference_To
4398                                    (RTE (RE_Dispatch_Table_Wrapper), Loc),
4399                  Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
4400                                    Constraints => DT_Constr_List)),
4401
4402              Expression          =>
4403                Make_Aggregate (Loc,
4404                  Expressions => DT_Aggr_List)));
4405
4406          Append_To (Result,
4407            Make_Attribute_Definition_Clause (Loc,
4408              Name       => New_Reference_To (Iface_DT, Loc),
4409              Chars      => Name_Alignment,
4410
4411              Expression =>
4412                Make_Attribute_Reference (Loc,
4413                  Prefix         =>
4414                    New_Reference_To (RTE (RE_Integer_Address), Loc),
4415                  Attribute_Name => Name_Alignment)));
4416
4417          if Exporting_Table then
4418             Export_DT (Typ, Iface_DT, Suffix_Index);
4419
4420          --  Generate code to create the pointer to the dispatch table
4421
4422          --    Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4423
4424          --  Note: This declaration is not added here if the table is exported
4425          --  because in such case Make_Tags has already added this declaration.
4426
4427          else
4428             Append_To (Result,
4429               Make_Object_Declaration (Loc,
4430                 Defining_Identifier => Iface_DT_Ptr,
4431                 Constant_Present    => True,
4432
4433                 Object_Definition   =>
4434                   New_Reference_To (RTE (RE_Interface_Tag), Loc),
4435
4436                 Expression          =>
4437                   Unchecked_Convert_To (RTE (RE_Interface_Tag),
4438                     Make_Attribute_Reference (Loc,
4439                       Prefix         =>
4440                         Make_Selected_Component (Loc,
4441                           Prefix        => New_Reference_To (Iface_DT, Loc),
4442                           Selector_Name =>
4443                             New_Occurrence_Of
4444                               (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4445                       Attribute_Name => Name_Address))));
4446          end if;
4447
4448          Append_To (Result,
4449            Make_Object_Declaration (Loc,
4450              Defining_Identifier => Predef_Prims_Ptr,
4451              Constant_Present    => True,
4452
4453              Object_Definition   =>
4454                New_Reference_To (RTE (RE_Address), Loc),
4455
4456              Expression          =>
4457                Make_Attribute_Reference (Loc,
4458                  Prefix         =>
4459                    Make_Selected_Component (Loc,
4460                      Prefix        => New_Reference_To (Iface_DT, Loc),
4461                      Selector_Name =>
4462                        New_Occurrence_Of
4463                          (RTE_Record_Component (RE_Predef_Prims), Loc)),
4464                  Attribute_Name => Name_Address)));
4465
4466          --  Remember entities containing dispatch tables
4467
4468          Append_Elmt (Predef_Prims, DT_Decl);
4469          Append_Elmt (Iface_DT, DT_Decl);
4470       end Make_Secondary_DT;
4471
4472       --  Local variables
4473
4474       Elab_Code          : constant List_Id := New_List;
4475       Result             : constant List_Id := New_List;
4476       Tname              : constant Name_Id := Chars (Typ);
4477       AI                 : Elmt_Id;
4478       AI_Tag_Elmt        : Elmt_Id;
4479       AI_Tag_Comp        : Elmt_Id;
4480       DT_Aggr_List       : List_Id;
4481       DT_Constr_List     : List_Id;
4482       DT_Ptr             : Entity_Id;
4483       ITable             : Node_Id;
4484       I_Depth            : Nat := 0;
4485       Iface_Table_Node   : Node_Id;
4486       Name_ITable        : Name_Id;
4487       Nb_Predef_Prims    : Nat := 0;
4488       Nb_Prim            : Nat := 0;
4489       New_Node           : Node_Id;
4490       Num_Ifaces         : Nat := 0;
4491       Parent_Typ         : Entity_Id;
4492       Prim               : Entity_Id;
4493       Prim_Elmt          : Elmt_Id;
4494       Prim_Ops_Aggr_List : List_Id;
4495       Suffix_Index       : Int;
4496       Typ_Comps          : Elist_Id;
4497       Typ_Ifaces         : Elist_Id;
4498       TSD_Aggr_List      : List_Id;
4499       TSD_Tags_List      : List_Id;
4500
4501       --  The following name entries are used by Make_DT to generate a number
4502       --  of entities related to a tagged type. These entities may be generated
4503       --  in a scope other than that of the tagged type declaration, and if
4504       --  the entities for two tagged types with the same name happen to be
4505       --  generated in the same scope, we have to take care to use different
4506       --  names. This is achieved by means of a unique serial number appended
4507       --  to each generated entity name.
4508
4509       Name_DT           : constant Name_Id :=
4510                             New_External_Name (Tname, 'T', Suffix_Index => -1);
4511       Name_Exname       : constant Name_Id :=
4512                             New_External_Name (Tname, 'E', Suffix_Index => -1);
4513       Name_HT_Link      : constant Name_Id :=
4514                             New_External_Name (Tname, 'H', Suffix_Index => -1);
4515       Name_Predef_Prims : constant Name_Id :=
4516                             New_External_Name (Tname, 'R', Suffix_Index => -1);
4517       Name_SSD          : constant Name_Id :=
4518                             New_External_Name (Tname, 'S', Suffix_Index => -1);
4519       Name_TSD          : constant Name_Id :=
4520                             New_External_Name (Tname, 'B', Suffix_Index => -1);
4521
4522       --  Entities built with above names
4523
4524       DT           : constant Entity_Id :=
4525                        Make_Defining_Identifier (Loc, Name_DT);
4526       Exname       : constant Entity_Id :=
4527                        Make_Defining_Identifier (Loc, Name_Exname);
4528       HT_Link      : constant Entity_Id :=
4529                        Make_Defining_Identifier (Loc, Name_HT_Link);
4530       Predef_Prims : constant Entity_Id :=
4531                        Make_Defining_Identifier (Loc, Name_Predef_Prims);
4532       SSD          : constant Entity_Id :=
4533                        Make_Defining_Identifier (Loc, Name_SSD);
4534       TSD          : constant Entity_Id :=
4535                        Make_Defining_Identifier (Loc, Name_TSD);
4536
4537    --  Start of processing for Make_DT
4538
4539    begin
4540       pragma Assert (Is_Frozen (Typ));
4541
4542       --  Handle cases in which there is no need to build the dispatch table
4543
4544       if Has_Dispatch_Table (Typ)
4545         or else No (Access_Disp_Table (Typ))
4546         or else Is_CPP_Class (Typ)
4547         or else Convention (Typ) = Convention_CIL
4548         or else Convention (Typ) = Convention_Java
4549       then
4550          return Result;
4551
4552       elsif No_Run_Time_Mode then
4553          Error_Msg_CRT ("tagged types", Typ);
4554          return Result;
4555
4556       elsif not RTE_Available (RE_Tag) then
4557          Append_To (Result,
4558            Make_Object_Declaration (Loc,
4559              Defining_Identifier => Node (First_Elmt
4560                                            (Access_Disp_Table (Typ))),
4561              Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
4562              Constant_Present    => True,
4563              Expression =>
4564                Unchecked_Convert_To (RTE (RE_Tag),
4565                  New_Reference_To (RTE (RE_Null_Address), Loc))));
4566
4567          Analyze_List (Result, Suppress => All_Checks);
4568          Error_Msg_CRT ("tagged types", Typ);
4569          return Result;
4570       end if;
4571
4572       --  Ensure that the value of Max_Predef_Prims defined in a-tags is
4573       --  correct. Valid values are 9 under configurable runtime or 15
4574       --  with full runtime.
4575
4576       if RTE_Available (RE_Interface_Data) then
4577          if Max_Predef_Prims /= 15 then
4578             Error_Msg_N ("run-time library configuration error", Typ);
4579             return Result;
4580          end if;
4581       else
4582          if Max_Predef_Prims /= 9 then
4583             Error_Msg_N ("run-time library configuration error", Typ);
4584             Error_Msg_CRT ("tagged types", Typ);
4585             return Result;
4586          end if;
4587       end if;
4588
4589       --  Initialize Parent_Typ handling private types
4590
4591       Parent_Typ := Etype (Typ);
4592
4593       if Present (Full_View (Parent_Typ)) then
4594          Parent_Typ := Full_View (Parent_Typ);
4595       end if;
4596
4597       --  Ensure that all the primitives are frozen. This is only required when
4598       --  building static dispatch tables --- the primitives must be frozen to
4599       --  be referenced (otherwise we have problems with the backend). It is
4600       --  not a requirement with nonstatic dispatch tables because in this case
4601       --  we generate now an empty dispatch table; the extra code required to
4602       --  register the primitives in the slots will be generated later --- when
4603       --  each primitive is frozen (see Freeze_Subprogram).
4604
4605       if Building_Static_DT (Typ) then
4606          declare
4607             Save      : constant Boolean := Freezing_Library_Level_Tagged_Type;
4608             Prim      : Entity_Id;
4609             Prim_Elmt : Elmt_Id;
4610             Frnodes   : List_Id;
4611
4612          begin
4613             Freezing_Library_Level_Tagged_Type := True;
4614
4615             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4616             while Present (Prim_Elmt) loop
4617                Prim    := Node (Prim_Elmt);
4618                Frnodes := Freeze_Entity (Prim, Typ);
4619
4620                declare
4621                   F : Entity_Id;
4622
4623                begin
4624                   F := First_Formal (Prim);
4625                   while Present (F) loop
4626                      Check_Premature_Freezing (Prim, Typ, Etype (F));
4627                      Next_Formal (F);
4628                   end loop;
4629
4630                   Check_Premature_Freezing (Prim, Typ, Etype (Prim));
4631                end;
4632
4633                if Present (Frnodes) then
4634                   Append_List_To (Result, Frnodes);
4635                end if;
4636
4637                Next_Elmt (Prim_Elmt);
4638             end loop;
4639
4640             Freezing_Library_Level_Tagged_Type := Save;
4641          end;
4642       end if;
4643
4644       --  Ada 2005 (AI-251): Build the secondary dispatch tables
4645
4646       if Has_Interfaces (Typ) then
4647          Collect_Interface_Components (Typ, Typ_Comps);
4648
4649          --  Each secondary dispatch table is assigned an unique positive
4650          --  suffix index; such value also corresponds with the location of
4651          --  its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4652
4653          --  Note: This value must be kept sync with the Suffix_Index values
4654          --  generated by Make_Tags
4655
4656          Suffix_Index := 1;
4657          AI_Tag_Elmt  :=
4658            Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4659
4660          AI_Tag_Comp := First_Elmt (Typ_Comps);
4661          while Present (AI_Tag_Comp) loop
4662             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
4663
4664             --  Build the secondary table containing pointers to thunks
4665
4666             Make_Secondary_DT
4667              (Typ             => Typ,
4668               Iface           => Base_Type (Related_Type (Node (AI_Tag_Comp))),
4669               Suffix_Index    => Suffix_Index,
4670               Num_Iface_Prims => UI_To_Int
4671                                    (DT_Entry_Count (Node (AI_Tag_Comp))),
4672               Iface_DT_Ptr    => Node (AI_Tag_Elmt),
4673               Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4674               Build_Thunks    => True,
4675               Result          => Result);
4676
4677             --  Skip secondary dispatch table referencing thunks to predefined
4678             --  primitives.
4679
4680             Next_Elmt (AI_Tag_Elmt);
4681             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
4682
4683             --  Secondary dispatch table referencing user-defined primitives
4684             --  covered by this interface.
4685
4686             Next_Elmt (AI_Tag_Elmt);
4687             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
4688
4689             --  Build the secondary table containing pointers to primitives
4690             --  (used to give support to Generic Dispatching Constructors).
4691
4692             Make_Secondary_DT
4693               (Typ              => Typ,
4694                Iface            => Base_Type
4695                                      (Related_Type (Node (AI_Tag_Comp))),
4696                Suffix_Index     => -1,
4697                Num_Iface_Prims  => UI_To_Int
4698                                      (DT_Entry_Count (Node (AI_Tag_Comp))),
4699                Iface_DT_Ptr     => Node (AI_Tag_Elmt),
4700                Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4701                Build_Thunks     => False,
4702                Result           => Result);
4703
4704             --  Skip secondary dispatch table referencing predefined primitives
4705
4706             Next_Elmt (AI_Tag_Elmt);
4707             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
4708
4709             Suffix_Index := Suffix_Index + 1;
4710             Next_Elmt (AI_Tag_Elmt);
4711             Next_Elmt (AI_Tag_Comp);
4712          end loop;
4713       end if;
4714
4715       --  Get the _tag entity and number of primitives of its dispatch table
4716
4717       DT_Ptr  := Node (First_Elmt (Access_Disp_Table (Typ)));
4718       Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
4719
4720       Set_Is_Statically_Allocated (DT,  Is_Library_Level_Tagged_Type (Typ));
4721       Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
4722       Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
4723       Set_Is_Statically_Allocated (Predef_Prims,
4724         Is_Library_Level_Tagged_Type (Typ));
4725
4726       --  In case of locally defined tagged type we declare the object
4727       --  containing the dispatch table by means of a variable. Its
4728       --  initialization is done later by means of an assignment. This is
4729       --  required to generate its External_Tag.
4730
4731       if not Building_Static_DT (Typ) then
4732
4733          --  Generate:
4734          --    DT     : No_Dispatch_Table_Wrapper;
4735          --    for DT'Alignment use Address'Alignment;
4736          --    DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4737
4738          if not Has_DT (Typ) then
4739             Append_To (Result,
4740               Make_Object_Declaration (Loc,
4741                 Defining_Identifier => DT,
4742                 Aliased_Present     => True,
4743                 Constant_Present    => False,
4744                 Object_Definition   =>
4745                   New_Reference_To
4746                     (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
4747
4748             Append_To (Result,
4749               Make_Attribute_Definition_Clause (Loc,
4750                 Name       => New_Reference_To (DT, Loc),
4751                 Chars      => Name_Alignment,
4752                 Expression =>
4753                   Make_Attribute_Reference (Loc,
4754                     Prefix =>
4755                       New_Reference_To (RTE (RE_Integer_Address), Loc),
4756                     Attribute_Name => Name_Alignment)));
4757
4758             Append_To (Result,
4759               Make_Object_Declaration (Loc,
4760                 Defining_Identifier => DT_Ptr,
4761                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
4762                 Constant_Present    => True,
4763                 Expression =>
4764                   Unchecked_Convert_To (RTE (RE_Tag),
4765                     Make_Attribute_Reference (Loc,
4766                       Prefix =>
4767                         Make_Selected_Component (Loc,
4768                           Prefix => New_Reference_To (DT, Loc),
4769                         Selector_Name =>
4770                           New_Occurrence_Of
4771                             (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4772                       Attribute_Name => Name_Address))));
4773
4774             Set_Is_Statically_Allocated (DT_Ptr,
4775               Is_Library_Level_Tagged_Type (Typ));
4776
4777             --  Generate the SCIL node for the previous object declaration
4778             --  because it has a tag initialization.
4779
4780             if Generate_SCIL then
4781                New_Node :=
4782                  Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4783                Set_SCIL_Entity (New_Node, Typ);
4784                Set_SCIL_Node (Last (Result), New_Node);
4785             end if;
4786
4787          --  Generate:
4788          --    DT : Dispatch_Table_Wrapper (Nb_Prim);
4789          --    for DT'Alignment use Address'Alignment;
4790          --    DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4791
4792          else
4793             --  If the tagged type has no primitives we add a dummy slot
4794             --  whose address will be the tag of this type.
4795
4796             if Nb_Prim = 0 then
4797                DT_Constr_List :=
4798                  New_List (Make_Integer_Literal (Loc, 1));
4799             else
4800                DT_Constr_List :=
4801                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
4802             end if;
4803
4804             Append_To (Result,
4805               Make_Object_Declaration (Loc,
4806                 Defining_Identifier => DT,
4807                 Aliased_Present     => True,
4808                 Constant_Present    => False,
4809                 Object_Definition   =>
4810                   Make_Subtype_Indication (Loc,
4811                     Subtype_Mark =>
4812                       New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
4813                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4814                                     Constraints => DT_Constr_List))));
4815
4816             Append_To (Result,
4817               Make_Attribute_Definition_Clause (Loc,
4818                 Name       => New_Reference_To (DT, Loc),
4819                 Chars      => Name_Alignment,
4820                 Expression =>
4821                   Make_Attribute_Reference (Loc,
4822                     Prefix =>
4823                       New_Reference_To (RTE (RE_Integer_Address), Loc),
4824                     Attribute_Name => Name_Alignment)));
4825
4826             Append_To (Result,
4827               Make_Object_Declaration (Loc,
4828                 Defining_Identifier => DT_Ptr,
4829                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
4830                 Constant_Present    => True,
4831                 Expression =>
4832                   Unchecked_Convert_To (RTE (RE_Tag),
4833                     Make_Attribute_Reference (Loc,
4834                       Prefix =>
4835                         Make_Selected_Component (Loc,
4836                           Prefix => New_Reference_To (DT, Loc),
4837                         Selector_Name =>
4838                           New_Occurrence_Of
4839                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4840                       Attribute_Name => Name_Address))));
4841
4842             Set_Is_Statically_Allocated (DT_Ptr,
4843               Is_Library_Level_Tagged_Type (Typ));
4844
4845             --  Generate the SCIL node for the previous object declaration
4846             --  because it has a tag initialization.
4847
4848             if Generate_SCIL then
4849                New_Node :=
4850                  Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4851                Set_SCIL_Entity (New_Node, Typ);
4852                Set_SCIL_Node (Last (Result), New_Node);
4853             end if;
4854
4855             Append_To (Result,
4856               Make_Object_Declaration (Loc,
4857                 Defining_Identifier =>
4858                   Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
4859                 Constant_Present    => True,
4860                 Object_Definition   => New_Reference_To
4861                                             (RTE (RE_Address), Loc),
4862                 Expression =>
4863                   Make_Attribute_Reference (Loc,
4864                     Prefix =>
4865                       Make_Selected_Component (Loc,
4866                         Prefix => New_Reference_To (DT, Loc),
4867                       Selector_Name =>
4868                         New_Occurrence_Of
4869                           (RTE_Record_Component (RE_Predef_Prims), Loc)),
4870                     Attribute_Name => Name_Address)));
4871          end if;
4872       end if;
4873
4874       --  Generate: Exname : constant String := full_qualified_name (typ);
4875       --  The type itself may be an anonymous parent type, so use the first
4876       --  subtype to have a user-recognizable name.
4877
4878       Append_To (Result,
4879         Make_Object_Declaration (Loc,
4880           Defining_Identifier => Exname,
4881           Constant_Present    => True,
4882           Object_Definition   => New_Reference_To (Standard_String, Loc),
4883           Expression =>
4884             Make_String_Literal (Loc,
4885               Fully_Qualified_Name_String (First_Subtype (Typ)))));
4886
4887       Set_Is_Statically_Allocated (Exname);
4888       Set_Is_True_Constant (Exname);
4889
4890       --  Declare the object used by Ada.Tags.Register_Tag
4891
4892       if RTE_Available (RE_Register_Tag) then
4893          Append_To (Result,
4894            Make_Object_Declaration (Loc,
4895              Defining_Identifier => HT_Link,
4896              Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc)));
4897       end if;
4898
4899       --  Generate code to create the storage for the type specific data object
4900       --  with enough space to store the tags of the ancestors plus the tags
4901       --  of all the implemented interfaces (as described in a-tags.adb).
4902
4903       --   TSD : Type_Specific_Data (I_Depth) :=
4904       --           (Idepth             => I_Depth,
4905       --            Access_Level       => Type_Access_Level (Typ),
4906       --            Alignment          => Typ'Alignment,
4907       --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
4908       --            External_Tag       => Cstring_Ptr!(Exname'Address))
4909       --            HT_Link            => HT_Link'Address,
4910       --            Transportable      => <<boolean-value>>,
4911       --            Type_Is_Abstract   => <<boolean-value>>,
4912       --            Needs_Finalization => <<boolean-value>>,
4913       --            [ Size_Func         => Size_Prim'Access, ]
4914       --            [ Interfaces_Table  => <<access-value>>, ]
4915       --            [ SSD               => SSD_Table'Address ]
4916       --            Tags_Table         => (0 => null,
4917       --                                   1 => Parent'Tag
4918       --                                   ...);
4919       --   for TSD'Alignment use Address'Alignment
4920
4921       TSD_Aggr_List := New_List;
4922
4923       --  Idepth: Count ancestors to compute the inheritance depth. For private
4924       --  extensions, always go to the full view in order to compute the real
4925       --  inheritance depth.
4926
4927       declare
4928          Current_Typ : Entity_Id;
4929          Parent_Typ  : Entity_Id;
4930
4931       begin
4932          I_Depth     := 0;
4933          Current_Typ := Typ;
4934          loop
4935             Parent_Typ := Etype (Current_Typ);
4936
4937             if Is_Private_Type (Parent_Typ) then
4938                Parent_Typ := Full_View (Base_Type (Parent_Typ));
4939             end if;
4940
4941             exit when Parent_Typ = Current_Typ;
4942
4943             I_Depth := I_Depth + 1;
4944             Current_Typ := Parent_Typ;
4945          end loop;
4946       end;
4947
4948       Append_To (TSD_Aggr_List,
4949         Make_Integer_Literal (Loc, I_Depth));
4950
4951       --  Access_Level
4952
4953       Append_To (TSD_Aggr_List,
4954         Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
4955
4956       --  Alignment
4957
4958       --  For CPP types we cannot rely on the value of 'Alignment provided
4959       --  by the backend to initialize this TSD field.
4960
4961       if Convention (Typ) = Convention_CPP
4962         or else Is_CPP_Class (Root_Type (Typ))
4963       then
4964          Append_To (TSD_Aggr_List,
4965            Make_Integer_Literal (Loc, 0));
4966       else
4967          Append_To (TSD_Aggr_List,
4968            Make_Attribute_Reference (Loc,
4969              Prefix => New_Reference_To (Typ, Loc),
4970              Attribute_Name => Name_Alignment));
4971       end if;
4972
4973       --  Expanded_Name
4974
4975       Append_To (TSD_Aggr_List,
4976         Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4977           Make_Attribute_Reference (Loc,
4978             Prefix         => New_Reference_To (Exname, Loc),
4979             Attribute_Name => Name_Address)));
4980
4981       --  External_Tag of a local tagged type
4982
4983       --     <typ>A : constant String :=
4984       --                "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4985
4986       --  The reason we generate this strange name is that we do not want to
4987       --  enter local tagged types in the global hash table used to compute
4988       --  the Internal_Tag attribute for two reasons:
4989
4990       --    1. It is hard to avoid a tasking race condition for entering the
4991       --    entry into the hash table.
4992
4993       --    2. It would cause a storage leak, unless we rig up considerable
4994       --    mechanism to remove the entry from the hash table on exit.
4995
4996       --  So what we do is to generate the above external tag name, where the
4997       --  hex address is the address of the local dispatch table (i.e. exactly
4998       --  the value we want if Internal_Tag is computed from this string).
4999
5000       --  Of course this value will only be valid if the tagged type is still
5001       --  in scope, but it clearly must be erroneous to compute the internal
5002       --  tag of a tagged type that is out of scope!
5003
5004       --  We don't do this processing if an explicit external tag has been
5005       --  specified. That's an odd case for which we have already issued a
5006       --  warning, where we will not be able to compute the internal tag.
5007
5008       if not Is_Library_Level_Entity (Typ)
5009         and then not Has_External_Tag_Rep_Clause (Typ)
5010       then
5011          declare
5012             Exname      : constant Entity_Id :=
5013                             Make_Defining_Identifier (Loc,
5014                               New_External_Name (Tname, 'A'));
5015
5016             Full_Name   : constant String_Id :=
5017                             Fully_Qualified_Name_String (First_Subtype (Typ));
5018             Str1_Id     : String_Id;
5019             Str2_Id     : String_Id;
5020
5021          begin
5022             --  Generate:
5023             --    Str1 = "Internal tag at 16#";
5024
5025             Start_String;
5026             Store_String_Chars ("Internal tag at 16#");
5027             Str1_Id := End_String;
5028
5029             --  Generate:
5030             --    Str2 = "#: <type-full-name>";
5031
5032             Start_String;
5033             Store_String_Chars ("#: ");
5034             Store_String_Chars (Full_Name);
5035             Str2_Id := End_String;
5036
5037             --  Generate:
5038             --    Exname : constant String :=
5039             --               Str1 & Address_Image (Tag) & Str2;
5040
5041             if RTE_Available (RE_Address_Image) then
5042                Append_To (Result,
5043                  Make_Object_Declaration (Loc,
5044                    Defining_Identifier => Exname,
5045                    Constant_Present    => True,
5046                    Object_Definition   => New_Reference_To
5047                                             (Standard_String, Loc),
5048                    Expression =>
5049                      Make_Op_Concat (Loc,
5050                        Left_Opnd =>
5051                          Make_String_Literal (Loc, Str1_Id),
5052                        Right_Opnd =>
5053                          Make_Op_Concat (Loc,
5054                            Left_Opnd =>
5055                              Make_Function_Call (Loc,
5056                                Name =>
5057                                  New_Reference_To
5058                                    (RTE (RE_Address_Image), Loc),
5059                                Parameter_Associations => New_List (
5060                                  Unchecked_Convert_To (RTE (RE_Address),
5061                                    New_Reference_To (DT_Ptr, Loc)))),
5062                            Right_Opnd =>
5063                              Make_String_Literal (Loc, Str2_Id)))));
5064
5065             else
5066                Append_To (Result,
5067                  Make_Object_Declaration (Loc,
5068                    Defining_Identifier => Exname,
5069                    Constant_Present    => True,
5070                    Object_Definition   => New_Reference_To
5071                                             (Standard_String, Loc),
5072                    Expression =>
5073                      Make_Op_Concat (Loc,
5074                        Left_Opnd =>
5075                          Make_String_Literal (Loc, Str1_Id),
5076                        Right_Opnd =>
5077                          Make_String_Literal (Loc, Str2_Id))));
5078             end if;
5079
5080             New_Node :=
5081               Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5082                 Make_Attribute_Reference (Loc,
5083                   Prefix => New_Reference_To (Exname, Loc),
5084                   Attribute_Name => Name_Address));
5085          end;
5086
5087       --  External tag of a library-level tagged type: Check for a definition
5088       --  of External_Tag. The clause is considered only if it applies to this
5089       --  specific tagged type, as opposed to one of its ancestors.
5090       --  If the type is an unconstrained type extension, we are building the
5091       --  dispatch table of its anonymous base type, so the external tag, if
5092       --  any was specified, must be retrieved from the first subtype. Go to
5093       --  the full view in case the clause is in the private part.
5094
5095       else
5096          declare
5097             Def : constant Node_Id := Get_Attribute_Definition_Clause
5098                                         (Underlying_Type (First_Subtype (Typ)),
5099                                          Attribute_External_Tag);
5100
5101             Old_Val : String_Id;
5102             New_Val : String_Id;
5103             E       : Entity_Id;
5104
5105          begin
5106             if not Present (Def)
5107               or else Entity (Name (Def)) /= First_Subtype (Typ)
5108             then
5109                New_Node :=
5110                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5111                    Make_Attribute_Reference (Loc,
5112                      Prefix         => New_Reference_To (Exname, Loc),
5113                      Attribute_Name => Name_Address));
5114             else
5115                Old_Val := Strval (Expr_Value_S (Expression (Def)));
5116
5117                --  For the rep clause "for <typ>'external_tag use y" generate:
5118
5119                --     <typ>A : constant string := y;
5120                --
5121                --  <typ>A'Address is used to set the External_Tag component
5122                --  of the TSD
5123
5124                --  Create a new nul terminated string if it is not already
5125
5126                if String_Length (Old_Val) > 0
5127                  and then
5128                   Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
5129                then
5130                   New_Val := Old_Val;
5131                else
5132                   Start_String (Old_Val);
5133                   Store_String_Char (Get_Char_Code (ASCII.NUL));
5134                   New_Val := End_String;
5135                end if;
5136
5137                E := Make_Defining_Identifier (Loc,
5138                       New_External_Name (Chars (Typ), 'A'));
5139
5140                Append_To (Result,
5141                  Make_Object_Declaration (Loc,
5142                    Defining_Identifier => E,
5143                    Constant_Present    => True,
5144                    Object_Definition   =>
5145                      New_Reference_To (Standard_String, Loc),
5146                    Expression          =>
5147                      Make_String_Literal (Loc, New_Val)));
5148
5149                New_Node :=
5150                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5151                    Make_Attribute_Reference (Loc,
5152                      Prefix => New_Reference_To (E, Loc),
5153                      Attribute_Name => Name_Address));
5154             end if;
5155          end;
5156       end if;
5157
5158       Append_To (TSD_Aggr_List, New_Node);
5159
5160       --  HT_Link
5161
5162       if RTE_Available (RE_Register_Tag) then
5163          Append_To (TSD_Aggr_List,
5164            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5165              Make_Attribute_Reference (Loc,
5166                Prefix => New_Reference_To (HT_Link, Loc),
5167                Attribute_Name => Name_Address)));
5168       else
5169          Append_To (TSD_Aggr_List,
5170            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5171              New_Reference_To (RTE (RE_Null_Address), Loc)));
5172       end if;
5173
5174       --  Transportable: Set for types that can be used in remote calls
5175       --  with respect to E.4(18) legality rules.
5176
5177       declare
5178          Transportable : Entity_Id;
5179
5180       begin
5181          Transportable :=
5182            Boolean_Literals
5183              (Is_Pure (Typ)
5184                 or else Is_Shared_Passive (Typ)
5185                 or else
5186                   ((Is_Remote_Types (Typ)
5187                       or else Is_Remote_Call_Interface (Typ))
5188                    and then Original_View_In_Visible_Part (Typ))
5189                 or else not Comes_From_Source (Typ));
5190
5191          Append_To (TSD_Aggr_List,
5192             New_Occurrence_Of (Transportable, Loc));
5193       end;
5194
5195       --  Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is
5196       --  not available in the HIE runtime.
5197
5198       if RTE_Record_Component_Available (RE_Type_Is_Abstract) then
5199          declare
5200             Type_Is_Abstract : Entity_Id;
5201
5202          begin
5203             Type_Is_Abstract :=
5204               Boolean_Literals (Is_Abstract_Type (Typ));
5205
5206             Append_To (TSD_Aggr_List,
5207                New_Occurrence_Of (Type_Is_Abstract, Loc));
5208          end;
5209       end if;
5210
5211       --  Needs_Finalization: Set if the type is controlled or has controlled
5212       --  components.
5213
5214       declare
5215          Needs_Fin : Entity_Id;
5216
5217       begin
5218          Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
5219          Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
5220       end;
5221
5222       --  Size_Func
5223
5224       if RTE_Record_Component_Available (RE_Size_Func) then
5225
5226          --  Initialize this field to Null_Address if we are not building
5227          --  static dispatch tables static or if the size function is not
5228          --  available. In the former case we cannot initialize this field
5229          --  until the function is frozen and registered in the dispatch
5230          --  table (see Register_Primitive).
5231
5232          if not Building_Static_DT (Typ) or else not Has_DT (Typ) then
5233             Append_To (TSD_Aggr_List,
5234               Unchecked_Convert_To (RTE (RE_Size_Ptr),
5235                 New_Reference_To (RTE (RE_Null_Address), Loc)));
5236
5237          else
5238             declare
5239                Prim_Elmt : Elmt_Id;
5240                Prim      : Entity_Id;
5241                Size_Comp : Node_Id;
5242
5243             begin
5244                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5245                while Present (Prim_Elmt) loop
5246                   Prim := Node (Prim_Elmt);
5247
5248                   if Chars (Prim) = Name_uSize then
5249                      Prim := Ultimate_Alias (Prim);
5250
5251                      if Is_Abstract_Subprogram (Prim) then
5252                         Size_Comp :=
5253                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
5254                             New_Reference_To (RTE (RE_Null_Address), Loc));
5255                      else
5256                         Size_Comp :=
5257                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
5258                             Make_Attribute_Reference (Loc,
5259                               Prefix => New_Reference_To (Prim, Loc),
5260                               Attribute_Name => Name_Unrestricted_Access));
5261                      end if;
5262
5263                      exit;
5264                   end if;
5265
5266                   Next_Elmt (Prim_Elmt);
5267                end loop;
5268
5269                pragma Assert (Present (Size_Comp));
5270                Append_To (TSD_Aggr_List, Size_Comp);
5271             end;
5272          end if;
5273       end if;
5274
5275       --  Interfaces_Table (required for AI-405)
5276
5277       if RTE_Record_Component_Available (RE_Interfaces_Table) then
5278
5279          --  Count the number of interface types implemented by Typ
5280
5281          Collect_Interfaces (Typ, Typ_Ifaces);
5282
5283          AI := First_Elmt (Typ_Ifaces);
5284          while Present (AI) loop
5285             Num_Ifaces := Num_Ifaces + 1;
5286             Next_Elmt (AI);
5287          end loop;
5288
5289          if Num_Ifaces = 0 then
5290             Iface_Table_Node := Make_Null (Loc);
5291
5292          --  Generate the Interface_Table object
5293
5294          else
5295             declare
5296                TSD_Ifaces_List : constant List_Id := New_List;
5297                Elmt       : Elmt_Id;
5298                Sec_DT_Tag : Node_Id;
5299
5300             begin
5301                AI := First_Elmt (Typ_Ifaces);
5302                while Present (AI) loop
5303                   if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
5304                      Sec_DT_Tag :=
5305                        New_Reference_To (DT_Ptr, Loc);
5306                   else
5307                      Elmt :=
5308                        Next_Elmt
5309                         (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5310                      pragma Assert (Has_Thunks (Node (Elmt)));
5311
5312                      while Is_Tag (Node (Elmt))
5313                         and then not
5314                           Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
5315                                        Use_Full_View => True)
5316                      loop
5317                         pragma Assert (Has_Thunks (Node (Elmt)));
5318                         Next_Elmt (Elmt);
5319                         pragma Assert (Has_Thunks (Node (Elmt)));
5320                         Next_Elmt (Elmt);
5321                         pragma Assert (not Has_Thunks (Node (Elmt)));
5322                         Next_Elmt (Elmt);
5323                         pragma Assert (not Has_Thunks (Node (Elmt)));
5324                         Next_Elmt (Elmt);
5325                      end loop;
5326
5327                      pragma Assert (Ekind (Node (Elmt)) = E_Constant
5328                        and then not
5329                          Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
5330                      Sec_DT_Tag :=
5331                        New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
5332                                          Loc);
5333                   end if;
5334
5335                   Append_To (TSD_Ifaces_List,
5336                      Make_Aggregate (Loc,
5337                        Expressions => New_List (
5338
5339                         --  Iface_Tag
5340
5341                         Unchecked_Convert_To (RTE (RE_Tag),
5342                           New_Reference_To
5343                             (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
5344                              Loc)),
5345
5346                         --  Static_Offset_To_Top
5347
5348                         New_Reference_To (Standard_True, Loc),
5349
5350                         --  Offset_To_Top_Value
5351
5352                         Make_Integer_Literal (Loc, 0),
5353
5354                         --  Offset_To_Top_Func
5355
5356                         Make_Null (Loc),
5357
5358                         --  Secondary_DT
5359
5360                         Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
5361
5362                         )));
5363
5364                   Next_Elmt (AI);
5365                end loop;
5366
5367                Name_ITable := New_External_Name (Tname, 'I');
5368                ITable      := Make_Defining_Identifier (Loc, Name_ITable);
5369                Set_Is_Statically_Allocated (ITable,
5370                  Is_Library_Level_Tagged_Type (Typ));
5371
5372                --  The table of interfaces is not constant; its slots are
5373                --  filled at run time by the IP routine using attribute
5374                --  'Position to know the location of the tag components
5375                --  (and this attribute cannot be safely used before the
5376                --  object is initialized).
5377
5378                Append_To (Result,
5379                  Make_Object_Declaration (Loc,
5380                    Defining_Identifier => ITable,
5381                    Aliased_Present     => True,
5382                    Constant_Present    => False,
5383                    Object_Definition   =>
5384                      Make_Subtype_Indication (Loc,
5385                        Subtype_Mark =>
5386                          New_Reference_To (RTE (RE_Interface_Data), Loc),
5387                        Constraint => Make_Index_Or_Discriminant_Constraint
5388                          (Loc,
5389                           Constraints => New_List (
5390                             Make_Integer_Literal (Loc, Num_Ifaces)))),
5391
5392                    Expression => Make_Aggregate (Loc,
5393                      Expressions => New_List (
5394                        Make_Integer_Literal (Loc, Num_Ifaces),
5395                        Make_Aggregate (Loc,
5396                          Expressions => TSD_Ifaces_List)))));
5397
5398                Append_To (Result,
5399                  Make_Attribute_Definition_Clause (Loc,
5400                    Name       => New_Reference_To (ITable, Loc),
5401                    Chars      => Name_Alignment,
5402                    Expression =>
5403                      Make_Attribute_Reference (Loc,
5404                        Prefix =>
5405                          New_Reference_To (RTE (RE_Integer_Address), Loc),
5406                        Attribute_Name => Name_Alignment)));
5407
5408                Iface_Table_Node :=
5409                  Make_Attribute_Reference (Loc,
5410                    Prefix         => New_Reference_To (ITable, Loc),
5411                    Attribute_Name => Name_Unchecked_Access);
5412             end;
5413          end if;
5414
5415          Append_To (TSD_Aggr_List, Iface_Table_Node);
5416       end if;
5417
5418       --  Generate the Select Specific Data table for synchronized types that
5419       --  implement synchronized interfaces. The size of the table is
5420       --  constrained by the number of non-predefined primitive operations.
5421
5422       if RTE_Record_Component_Available (RE_SSD) then
5423          if Ada_Version >= Ada_2005
5424            and then Has_DT (Typ)
5425            and then Is_Concurrent_Record_Type (Typ)
5426            and then Has_Interfaces (Typ)
5427            and then Nb_Prim > 0
5428            and then not Is_Abstract_Type (Typ)
5429            and then not Is_Controlled (Typ)
5430            and then not Restriction_Active (No_Dispatching_Calls)
5431            and then not Restriction_Active (No_Select_Statements)
5432          then
5433             Append_To (Result,
5434               Make_Object_Declaration (Loc,
5435                 Defining_Identifier => SSD,
5436                 Aliased_Present     => True,
5437                 Object_Definition   =>
5438                   Make_Subtype_Indication (Loc,
5439                     Subtype_Mark => New_Reference_To (
5440                       RTE (RE_Select_Specific_Data), Loc),
5441                     Constraint   =>
5442                       Make_Index_Or_Discriminant_Constraint (Loc,
5443                         Constraints => New_List (
5444                           Make_Integer_Literal (Loc, Nb_Prim))))));
5445
5446             Append_To (Result,
5447               Make_Attribute_Definition_Clause (Loc,
5448                 Name       => New_Reference_To (SSD, Loc),
5449                 Chars      => Name_Alignment,
5450                 Expression =>
5451                   Make_Attribute_Reference (Loc,
5452                     Prefix =>
5453                       New_Reference_To (RTE (RE_Integer_Address), Loc),
5454                     Attribute_Name => Name_Alignment)));
5455
5456             --  This table is initialized by Make_Select_Specific_Data_Table,
5457             --  which calls Set_Entry_Index and Set_Prim_Op_Kind.
5458
5459             Append_To (TSD_Aggr_List,
5460               Make_Attribute_Reference (Loc,
5461                 Prefix => New_Reference_To (SSD, Loc),
5462                 Attribute_Name => Name_Unchecked_Access));
5463          else
5464             Append_To (TSD_Aggr_List, Make_Null (Loc));
5465          end if;
5466       end if;
5467
5468       --  Initialize the table of ancestor tags. In case of interface types
5469       --  this table is not needed.
5470
5471       TSD_Tags_List := New_List;
5472
5473       --  If we are not statically allocating the dispatch table then we must
5474       --  fill position 0 with null because we still have not generated the
5475       --  tag of Typ.
5476
5477       if not Building_Static_DT (Typ)
5478         or else Is_Interface (Typ)
5479       then
5480          Append_To (TSD_Tags_List,
5481            Unchecked_Convert_To (RTE (RE_Tag),
5482              New_Reference_To (RTE (RE_Null_Address), Loc)));
5483
5484       --  Otherwise we can safely reference the tag
5485
5486       else
5487          Append_To (TSD_Tags_List,
5488            New_Reference_To (DT_Ptr, Loc));
5489       end if;
5490
5491       --  Fill the rest of the table with the tags of the ancestors
5492
5493       declare
5494          Current_Typ : Entity_Id;
5495          Parent_Typ  : Entity_Id;
5496          Pos         : Nat;
5497
5498       begin
5499          Pos := 1;
5500          Current_Typ := Typ;
5501
5502          loop
5503             Parent_Typ := Etype (Current_Typ);
5504
5505             if Is_Private_Type (Parent_Typ) then
5506                Parent_Typ := Full_View (Base_Type (Parent_Typ));
5507             end if;
5508
5509             exit when Parent_Typ = Current_Typ;
5510
5511             if Is_CPP_Class (Parent_Typ) then
5512
5513                --  The tags defined in the C++ side will be inherited when
5514                --  the object is constructed (Exp_Ch3.Build_Init_Procedure)
5515
5516                Append_To (TSD_Tags_List,
5517                  Unchecked_Convert_To (RTE (RE_Tag),
5518                    New_Reference_To (RTE (RE_Null_Address), Loc)));
5519             else
5520                Append_To (TSD_Tags_List,
5521                  New_Reference_To
5522                    (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
5523                     Loc));
5524             end if;
5525
5526             Pos := Pos + 1;
5527             Current_Typ := Parent_Typ;
5528          end loop;
5529
5530          pragma Assert (Pos = I_Depth + 1);
5531       end;
5532
5533       Append_To (TSD_Aggr_List,
5534         Make_Aggregate (Loc,
5535           Expressions => TSD_Tags_List));
5536
5537       --  Build the TSD object
5538
5539       Append_To (Result,
5540         Make_Object_Declaration (Loc,
5541           Defining_Identifier => TSD,
5542           Aliased_Present     => True,
5543           Constant_Present    => Building_Static_DT (Typ),
5544           Object_Definition   =>
5545             Make_Subtype_Indication (Loc,
5546               Subtype_Mark => New_Reference_To (
5547                 RTE (RE_Type_Specific_Data), Loc),
5548               Constraint =>
5549                 Make_Index_Or_Discriminant_Constraint (Loc,
5550                   Constraints => New_List (
5551                     Make_Integer_Literal (Loc, I_Depth)))),
5552
5553           Expression => Make_Aggregate (Loc,
5554             Expressions => TSD_Aggr_List)));
5555
5556       Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
5557
5558       Append_To (Result,
5559         Make_Attribute_Definition_Clause (Loc,
5560           Name       => New_Reference_To (TSD, Loc),
5561           Chars      => Name_Alignment,
5562           Expression =>
5563             Make_Attribute_Reference (Loc,
5564               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
5565               Attribute_Name => Name_Alignment)));
5566
5567       --  Initialize or declare the dispatch table object
5568
5569       if not Has_DT (Typ) then
5570          DT_Constr_List := New_List;
5571          DT_Aggr_List   := New_List;
5572
5573          --  Typeinfo
5574
5575          New_Node :=
5576            Make_Attribute_Reference (Loc,
5577              Prefix => New_Reference_To (TSD, Loc),
5578              Attribute_Name => Name_Address);
5579
5580          Append_To (DT_Constr_List, New_Node);
5581          Append_To (DT_Aggr_List,   New_Copy (New_Node));
5582          Append_To (DT_Aggr_List,   Make_Integer_Literal (Loc, 0));
5583
5584          --  In case of locally defined tagged types we have already declared
5585          --  and uninitialized object for the dispatch table, which is now
5586          --  initialized by means of the following assignment:
5587
5588          --    DT := (TSD'Address, 0);
5589
5590          if not Building_Static_DT (Typ) then
5591             Append_To (Result,
5592               Make_Assignment_Statement (Loc,
5593                 Name => New_Reference_To (DT, Loc),
5594                 Expression => Make_Aggregate (Loc,
5595                   Expressions => DT_Aggr_List)));
5596
5597          --  In case of library level tagged types we declare and export now
5598          --  the constant object containing the dummy dispatch table. There
5599          --  is no need to declare the tag here because it has been previously
5600          --  declared by Make_Tags
5601
5602          --   DT : aliased constant No_Dispatch_Table :=
5603          --          (NDT_TSD       => TSD'Address;
5604          --           NDT_Prims_Ptr => 0);
5605          --   for DT'Alignment use Address'Alignment;
5606
5607          else
5608             Append_To (Result,
5609               Make_Object_Declaration (Loc,
5610                 Defining_Identifier => DT,
5611                 Aliased_Present     => True,
5612                 Constant_Present    => True,
5613                 Object_Definition   =>
5614                   New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
5615                 Expression => Make_Aggregate (Loc,
5616                   Expressions => DT_Aggr_List)));
5617
5618             Append_To (Result,
5619               Make_Attribute_Definition_Clause (Loc,
5620                 Name       => New_Reference_To (DT, Loc),
5621                 Chars      => Name_Alignment,
5622                 Expression =>
5623                   Make_Attribute_Reference (Loc,
5624                     Prefix =>
5625                       New_Reference_To (RTE (RE_Integer_Address), Loc),
5626                     Attribute_Name => Name_Alignment)));
5627
5628             Export_DT (Typ, DT);
5629          end if;
5630
5631       --  Common case: Typ has a dispatch table
5632
5633       --  Generate:
5634
5635       --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5636       --                    (predef-prim-op-1'address,
5637       --                     predef-prim-op-2'address,
5638       --                     ...
5639       --                     predef-prim-op-n'address);
5640       --   for Predef_Prims'Alignment use Address'Alignment
5641
5642       --   DT : Dispatch_Table (Nb_Prims) :=
5643       --          (Signature => <sig-value>,
5644       --           Tag_Kind  => <tag_kind-value>,
5645       --           Predef_Prims => Predef_Prims'First'Address,
5646       --           Offset_To_Top => 0,
5647       --           TSD           => TSD'Address;
5648       --           Prims_Ptr     => (prim-op-1'address,
5649       --                             prim-op-2'address,
5650       --                             ...
5651       --                             prim-op-n'address));
5652       --   for DT'Alignment use Address'Alignment
5653
5654       else
5655          declare
5656             Pos : Nat;
5657
5658          begin
5659             if not Building_Static_DT (Typ) then
5660                Nb_Predef_Prims := Max_Predef_Prims;
5661
5662             else
5663                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5664                while Present (Prim_Elmt) loop
5665                   Prim := Node (Prim_Elmt);
5666
5667                   if Is_Predefined_Dispatching_Operation (Prim)
5668                     and then not Is_Abstract_Subprogram (Prim)
5669                   then
5670                      Pos := UI_To_Int (DT_Position (Prim));
5671
5672                      if Pos > Nb_Predef_Prims then
5673                         Nb_Predef_Prims := Pos;
5674                      end if;
5675                   end if;
5676
5677                   Next_Elmt (Prim_Elmt);
5678                end loop;
5679             end if;
5680
5681             declare
5682                Prim_Table : array
5683                               (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
5684                Decl       : Node_Id;
5685                E          : Entity_Id;
5686
5687             begin
5688                Prim_Ops_Aggr_List := New_List;
5689
5690                Prim_Table := (others => Empty);
5691
5692                if Building_Static_DT (Typ) then
5693                   Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
5694                   while Present (Prim_Elmt) loop
5695                      Prim := Node (Prim_Elmt);
5696
5697                      if Is_Predefined_Dispatching_Operation (Prim)
5698                        and then not Is_Abstract_Subprogram (Prim)
5699                        and then not Is_Eliminated (Prim)
5700                        and then not Present (Prim_Table
5701                                               (UI_To_Int (DT_Position (Prim))))
5702                      then
5703                         E := Ultimate_Alias (Prim);
5704                         pragma Assert (not Is_Abstract_Subprogram (E));
5705                         Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5706                      end if;
5707
5708                      Next_Elmt (Prim_Elmt);
5709                   end loop;
5710                end if;
5711
5712                for J in Prim_Table'Range loop
5713                   if Present (Prim_Table (J)) then
5714                      New_Node :=
5715                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5716                          Make_Attribute_Reference (Loc,
5717                            Prefix => New_Reference_To (Prim_Table (J), Loc),
5718                            Attribute_Name => Name_Unrestricted_Access));
5719                   else
5720                      New_Node := Make_Null (Loc);
5721                   end if;
5722
5723                   Append_To (Prim_Ops_Aggr_List, New_Node);
5724                end loop;
5725
5726                New_Node :=
5727                  Make_Aggregate (Loc,
5728                    Expressions => Prim_Ops_Aggr_List);
5729
5730                Decl :=
5731                  Make_Subtype_Declaration (Loc,
5732                    Defining_Identifier => Make_Temporary (Loc, 'S'),
5733                    Subtype_Indication  =>
5734                      New_Reference_To (RTE (RE_Address_Array), Loc));
5735
5736                Append_To (Result, Decl);
5737
5738                Append_To (Result,
5739                  Make_Object_Declaration (Loc,
5740                    Defining_Identifier => Predef_Prims,
5741                    Aliased_Present     => True,
5742                    Constant_Present    => Building_Static_DT (Typ),
5743                    Object_Definition   => New_Reference_To
5744                                            (Defining_Identifier (Decl), Loc),
5745                    Expression => New_Node));
5746
5747                --  Remember aggregates initializing dispatch tables
5748
5749                Append_Elmt (New_Node, DT_Aggr);
5750
5751                Append_To (Result,
5752                  Make_Attribute_Definition_Clause (Loc,
5753                    Name       => New_Reference_To (Predef_Prims, Loc),
5754                    Chars      => Name_Alignment,
5755                    Expression =>
5756                      Make_Attribute_Reference (Loc,
5757                        Prefix =>
5758                          New_Reference_To (RTE (RE_Integer_Address), Loc),
5759                        Attribute_Name => Name_Alignment)));
5760             end;
5761          end;
5762
5763          --  Stage 1: Initialize the discriminant and the record components
5764
5765          DT_Constr_List := New_List;
5766          DT_Aggr_List   := New_List;
5767
5768          --  Num_Prims. If the tagged type has no primitives we add a dummy
5769          --  slot whose address will be the tag of this type.
5770
5771          if Nb_Prim = 0 then
5772             New_Node := Make_Integer_Literal (Loc, 1);
5773          else
5774             New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5775          end if;
5776
5777          Append_To (DT_Constr_List, New_Node);
5778          Append_To (DT_Aggr_List,   New_Copy (New_Node));
5779
5780          --  Signature
5781
5782          if RTE_Record_Component_Available (RE_Signature) then
5783             Append_To (DT_Aggr_List,
5784               New_Reference_To (RTE (RE_Primary_DT), Loc));
5785          end if;
5786
5787          --  Tag_Kind
5788
5789          if RTE_Record_Component_Available (RE_Tag_Kind) then
5790             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
5791          end if;
5792
5793          --  Predef_Prims
5794
5795          Append_To (DT_Aggr_List,
5796            Make_Attribute_Reference (Loc,
5797              Prefix => New_Reference_To (Predef_Prims, Loc),
5798              Attribute_Name => Name_Address));
5799
5800          --  Offset_To_Top
5801
5802          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5803
5804          --  Typeinfo
5805
5806          Append_To (DT_Aggr_List,
5807            Make_Attribute_Reference (Loc,
5808              Prefix => New_Reference_To (TSD, Loc),
5809              Attribute_Name => Name_Address));
5810
5811          --  Stage 2: Initialize the table of user-defined primitive operations
5812
5813          Prim_Ops_Aggr_List := New_List;
5814
5815          if Nb_Prim = 0 then
5816             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5817
5818          elsif not Building_Static_DT (Typ) then
5819             for J in 1 .. Nb_Prim loop
5820                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5821             end loop;
5822
5823          else
5824             declare
5825                CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
5826                E            : Entity_Id;
5827                Prim         : Entity_Id;
5828                Prim_Elmt    : Elmt_Id;
5829                Prim_Pos     : Nat;
5830                Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
5831
5832             begin
5833                Prim_Table := (others => Empty);
5834
5835                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5836                while Present (Prim_Elmt) loop
5837                   Prim := Node (Prim_Elmt);
5838
5839                   --  Retrieve the ultimate alias of the primitive for proper
5840                   --  handling of renamings and eliminated primitives.
5841
5842                   E        := Ultimate_Alias (Prim);
5843                   Prim_Pos := UI_To_Int (DT_Position (E));
5844
5845                   --  Do not reference predefined primitives because they are
5846                   --  located in a separate dispatch table; skip entities with
5847                   --  attribute Interface_Alias because they are only required
5848                   --  to build secondary dispatch tables; skip abstract and
5849                   --  eliminated primitives; for derivations of CPP types skip
5850                   --  primitives located in the C++ part of the dispatch table
5851                   --  because their slot is initialized by the IC routine.
5852
5853                   if not Is_Predefined_Dispatching_Operation (Prim)
5854                     and then not Is_Predefined_Dispatching_Operation (E)
5855                     and then not Present (Interface_Alias (Prim))
5856                     and then not Is_Abstract_Subprogram (E)
5857                     and then not Is_Eliminated (E)
5858                     and then (not Is_CPP_Class (Root_Type (Typ))
5859                                or else Prim_Pos > CPP_Nb_Prims)
5860                   then
5861                      pragma Assert
5862                        (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
5863
5864                      Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5865                   end if;
5866
5867                   Next_Elmt (Prim_Elmt);
5868                end loop;
5869
5870                for J in Prim_Table'Range loop
5871                   if Present (Prim_Table (J)) then
5872                      New_Node :=
5873                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5874                          Make_Attribute_Reference (Loc,
5875                            Prefix => New_Reference_To (Prim_Table (J), Loc),
5876                            Attribute_Name => Name_Unrestricted_Access));
5877                   else
5878                      New_Node := Make_Null (Loc);
5879                   end if;
5880
5881                   Append_To (Prim_Ops_Aggr_List, New_Node);
5882                end loop;
5883             end;
5884          end if;
5885
5886          New_Node :=
5887            Make_Aggregate (Loc,
5888              Expressions => Prim_Ops_Aggr_List);
5889
5890          Append_To (DT_Aggr_List, New_Node);
5891
5892          --  Remember aggregates initializing dispatch tables
5893
5894          Append_Elmt (New_Node, DT_Aggr);
5895
5896          --  In case of locally defined tagged types we have already declared
5897          --  and uninitialized object for the dispatch table, which is now
5898          --  initialized by means of an assignment.
5899
5900          if not Building_Static_DT (Typ) then
5901             Append_To (Result,
5902               Make_Assignment_Statement (Loc,
5903                 Name => New_Reference_To (DT, Loc),
5904                 Expression => Make_Aggregate (Loc,
5905                   Expressions => DT_Aggr_List)));
5906
5907          --  In case of library level tagged types we declare now and export
5908          --  the constant object containing the dispatch table.
5909
5910          else
5911             Append_To (Result,
5912               Make_Object_Declaration (Loc,
5913                 Defining_Identifier => DT,
5914                 Aliased_Present     => True,
5915                 Constant_Present    => True,
5916                 Object_Definition   =>
5917                   Make_Subtype_Indication (Loc,
5918                     Subtype_Mark => New_Reference_To
5919                                       (RTE (RE_Dispatch_Table_Wrapper), Loc),
5920                     Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
5921                                       Constraints => DT_Constr_List)),
5922                 Expression => Make_Aggregate (Loc,
5923                   Expressions => DT_Aggr_List)));
5924
5925             Append_To (Result,
5926               Make_Attribute_Definition_Clause (Loc,
5927                 Name       => New_Reference_To (DT, Loc),
5928                 Chars      => Name_Alignment,
5929                 Expression =>
5930                   Make_Attribute_Reference (Loc,
5931                     Prefix =>
5932                       New_Reference_To (RTE (RE_Integer_Address), Loc),
5933                     Attribute_Name => Name_Alignment)));
5934
5935             Export_DT (Typ, DT);
5936          end if;
5937       end if;
5938
5939       --  Initialize the table of ancestor tags if not building static
5940       --  dispatch table
5941
5942       if not Building_Static_DT (Typ)
5943         and then not Is_Interface (Typ)
5944         and then not Is_CPP_Class (Typ)
5945       then
5946          Append_To (Result,
5947            Make_Assignment_Statement (Loc,
5948              Name =>
5949                Make_Indexed_Component (Loc,
5950                  Prefix =>
5951                    Make_Selected_Component (Loc,
5952                      Prefix =>
5953                        New_Reference_To (TSD, Loc),
5954                      Selector_Name =>
5955                        New_Reference_To
5956                          (RTE_Record_Component (RE_Tags_Table), Loc)),
5957                  Expressions =>
5958                     New_List (Make_Integer_Literal (Loc, 0))),
5959
5960              Expression =>
5961                New_Reference_To
5962                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
5963       end if;
5964
5965       --  Inherit the dispatch tables of the parent. There is no need to
5966       --  inherit anything from the parent when building static dispatch tables
5967       --  because the whole dispatch table (including inherited primitives) has
5968       --  been already built.
5969
5970       if Building_Static_DT (Typ) then
5971          null;
5972
5973       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
5974       --  in the init proc, and we don't need to fill them in here.
5975
5976       elsif Is_CPP_Class (Parent_Typ) then
5977          null;
5978
5979       --  Otherwise we fill in the dispatch tables here
5980
5981       else
5982          if Typ /= Parent_Typ
5983            and then not Is_Interface (Typ)
5984            and then not Restriction_Active (No_Dispatching_Calls)
5985          then
5986             --  Inherit the dispatch table
5987
5988             if not Is_Interface (Typ)
5989               and then not Is_Interface (Parent_Typ)
5990               and then not Is_CPP_Class (Parent_Typ)
5991             then
5992                declare
5993                   Nb_Prims : constant Int :=
5994                                UI_To_Int (DT_Entry_Count
5995                                  (First_Tag_Component (Parent_Typ)));
5996
5997                begin
5998                   Append_To (Elab_Code,
5999                     Build_Inherit_Predefined_Prims (Loc,
6000                       Old_Tag_Node =>
6001                         New_Reference_To
6002                           (Node
6003                            (Next_Elmt
6004                             (First_Elmt
6005                              (Access_Disp_Table (Parent_Typ)))), Loc),
6006                       New_Tag_Node =>
6007                         New_Reference_To
6008                           (Node
6009                            (Next_Elmt
6010                             (First_Elmt
6011                              (Access_Disp_Table (Typ)))), Loc)));
6012
6013                   if Nb_Prims /= 0 then
6014                      Append_To (Elab_Code,
6015                        Build_Inherit_Prims (Loc,
6016                          Typ          => Typ,
6017                          Old_Tag_Node =>
6018                            New_Reference_To
6019                              (Node
6020                               (First_Elmt
6021                                (Access_Disp_Table (Parent_Typ))), Loc),
6022                          New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
6023                          Num_Prims    => Nb_Prims));
6024                   end if;
6025                end;
6026             end if;
6027
6028             --  Inherit the secondary dispatch tables of the ancestor
6029
6030             if not Is_CPP_Class (Parent_Typ) then
6031                declare
6032                   Sec_DT_Ancestor : Elmt_Id :=
6033                                       Next_Elmt
6034                                        (Next_Elmt
6035                                         (First_Elmt
6036                                           (Access_Disp_Table (Parent_Typ))));
6037                   Sec_DT_Typ      : Elmt_Id :=
6038                                       Next_Elmt
6039                                        (Next_Elmt
6040                                          (First_Elmt
6041                                            (Access_Disp_Table (Typ))));
6042
6043                   procedure Copy_Secondary_DTs (Typ : Entity_Id);
6044                   --  Local procedure required to climb through the ancestors
6045                   --  and copy the contents of all their secondary dispatch
6046                   --  tables.
6047
6048                   ------------------------
6049                   -- Copy_Secondary_DTs --
6050                   ------------------------
6051
6052                   procedure Copy_Secondary_DTs (Typ : Entity_Id) is
6053                      E     : Entity_Id;
6054                      Iface : Elmt_Id;
6055
6056                   begin
6057                      --  Climb to the ancestor (if any) handling private types
6058
6059                      if Present (Full_View (Etype (Typ))) then
6060                         if Full_View (Etype (Typ)) /= Typ then
6061                            Copy_Secondary_DTs (Full_View (Etype (Typ)));
6062                         end if;
6063
6064                      elsif Etype (Typ) /= Typ then
6065                         Copy_Secondary_DTs (Etype (Typ));
6066                      end if;
6067
6068                      if Present (Interfaces (Typ))
6069                        and then not Is_Empty_Elmt_List (Interfaces (Typ))
6070                      then
6071                         Iface := First_Elmt (Interfaces (Typ));
6072                         E     := First_Entity (Typ);
6073                         while Present (E)
6074                           and then Present (Node (Sec_DT_Ancestor))
6075                           and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6076                         loop
6077                            if Is_Tag (E) and then Chars (E) /= Name_uTag then
6078                               declare
6079                                  Num_Prims : constant Int :=
6080                                                UI_To_Int (DT_Entry_Count (E));
6081
6082                               begin
6083                                  if not Is_Interface (Etype (Typ)) then
6084
6085                                     --  Inherit first secondary dispatch table
6086
6087                                     Append_To (Elab_Code,
6088                                       Build_Inherit_Predefined_Prims (Loc,
6089                                         Old_Tag_Node =>
6090                                           Unchecked_Convert_To (RTE (RE_Tag),
6091                                             New_Reference_To
6092                                               (Node
6093                                                 (Next_Elmt (Sec_DT_Ancestor)),
6094                                                Loc)),
6095                                         New_Tag_Node =>
6096                                           Unchecked_Convert_To (RTE (RE_Tag),
6097                                             New_Reference_To
6098                                               (Node (Next_Elmt (Sec_DT_Typ)),
6099                                                Loc))));
6100
6101                                     if Num_Prims /= 0 then
6102                                        Append_To (Elab_Code,
6103                                          Build_Inherit_Prims (Loc,
6104                                            Typ          => Node (Iface),
6105                                            Old_Tag_Node =>
6106                                              Unchecked_Convert_To
6107                                                (RTE (RE_Tag),
6108                                                 New_Reference_To
6109                                                   (Node (Sec_DT_Ancestor),
6110                                                    Loc)),
6111                                            New_Tag_Node =>
6112                                              Unchecked_Convert_To
6113                                               (RTE (RE_Tag),
6114                                                New_Reference_To
6115                                                  (Node (Sec_DT_Typ), Loc)),
6116                                            Num_Prims    => Num_Prims));
6117                                     end if;
6118                                  end if;
6119
6120                                  Next_Elmt (Sec_DT_Ancestor);
6121                                  Next_Elmt (Sec_DT_Typ);
6122
6123                                  --  Skip the secondary dispatch table of
6124                                  --  predefined primitives
6125
6126                                  Next_Elmt (Sec_DT_Ancestor);
6127                                  Next_Elmt (Sec_DT_Typ);
6128
6129                                  if not Is_Interface (Etype (Typ)) then
6130
6131                                     --  Inherit second secondary dispatch table
6132
6133                                     Append_To (Elab_Code,
6134                                       Build_Inherit_Predefined_Prims (Loc,
6135                                         Old_Tag_Node =>
6136                                           Unchecked_Convert_To (RTE (RE_Tag),
6137                                              New_Reference_To
6138                                                (Node
6139                                                  (Next_Elmt (Sec_DT_Ancestor)),
6140                                                 Loc)),
6141                                         New_Tag_Node =>
6142                                           Unchecked_Convert_To (RTE (RE_Tag),
6143                                             New_Reference_To
6144                                               (Node (Next_Elmt (Sec_DT_Typ)),
6145                                                Loc))));
6146
6147                                     if Num_Prims /= 0 then
6148                                        Append_To (Elab_Code,
6149                                          Build_Inherit_Prims (Loc,
6150                                            Typ          => Node (Iface),
6151                                            Old_Tag_Node =>
6152                                              Unchecked_Convert_To
6153                                                (RTE (RE_Tag),
6154                                                 New_Reference_To
6155                                                   (Node (Sec_DT_Ancestor),
6156                                                    Loc)),
6157                                            New_Tag_Node =>
6158                                              Unchecked_Convert_To
6159                                               (RTE (RE_Tag),
6160                                                New_Reference_To
6161                                                  (Node (Sec_DT_Typ), Loc)),
6162                                            Num_Prims    => Num_Prims));
6163                                     end if;
6164                                  end if;
6165                               end;
6166
6167                               Next_Elmt (Sec_DT_Ancestor);
6168                               Next_Elmt (Sec_DT_Typ);
6169
6170                               --  Skip the secondary dispatch table of
6171                               --  predefined primitives
6172
6173                               Next_Elmt (Sec_DT_Ancestor);
6174                               Next_Elmt (Sec_DT_Typ);
6175
6176                               Next_Elmt (Iface);
6177                            end if;
6178
6179                            Next_Entity (E);
6180                         end loop;
6181                      end if;
6182                   end Copy_Secondary_DTs;
6183
6184                begin
6185                   if Present (Node (Sec_DT_Ancestor))
6186                     and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6187                   then
6188                      --  Handle private types
6189
6190                      if Present (Full_View (Typ)) then
6191                         Copy_Secondary_DTs (Full_View (Typ));
6192                      else
6193                         Copy_Secondary_DTs (Typ);
6194                      end if;
6195                   end if;
6196                end;
6197             end if;
6198          end if;
6199       end if;
6200
6201       --  If the type has a representation clause which specifies its external
6202       --  tag then generate code to check if the external tag of this type is
6203       --  the same as the external tag of some other declaration.
6204
6205       --     Check_TSD (TSD'Unrestricted_Access);
6206
6207       --  This check is a consequence of AI05-0113-1/06, so it officially
6208       --  applies to Ada 2005 (and Ada 2012). It might be argued that it is
6209       --  a desirable check to add in Ada 95 mode, but we hesitate to make
6210       --  this change, as it would be incompatible, and could conceivably
6211       --  cause a problem in existing Aa 95 code.
6212
6213       --  We check for No_Run_Time_Mode here, because we do not want to pick
6214       --  up the RE_Check_TSD entity and call it in No_Run_Time mode.
6215
6216       if not No_Run_Time_Mode
6217         and then Ada_Version >= Ada_2005
6218         and then Has_External_Tag_Rep_Clause (Typ)
6219         and then RTE_Available (RE_Check_TSD)
6220         and then not Debug_Flag_QQ
6221       then
6222          Append_To (Elab_Code,
6223            Make_Procedure_Call_Statement (Loc,
6224              Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
6225              Parameter_Associations => New_List (
6226                Make_Attribute_Reference (Loc,
6227                  Prefix => New_Reference_To (TSD, Loc),
6228                  Attribute_Name => Name_Unchecked_Access))));
6229       end if;
6230
6231       --  Generate code to register the Tag in the External_Tag hash table for
6232       --  the pure Ada type only.
6233
6234       --        Register_Tag (Dt_Ptr);
6235
6236       --  Skip this action in the following cases:
6237       --    1) if Register_Tag is not available.
6238       --    2) in No_Run_Time mode.
6239       --    3) if Typ is not defined at the library level (this is required
6240       --       to avoid adding concurrency control to the hash table used
6241       --       by the run-time to register the tags).
6242
6243       if not No_Run_Time_Mode
6244         and then Is_Library_Level_Entity (Typ)
6245         and then RTE_Available (RE_Register_Tag)
6246       then
6247          Append_To (Elab_Code,
6248            Make_Procedure_Call_Statement (Loc,
6249              Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
6250              Parameter_Associations =>
6251                New_List (New_Reference_To (DT_Ptr, Loc))));
6252       end if;
6253
6254       if not Is_Empty_List (Elab_Code) then
6255          Append_List_To (Result, Elab_Code);
6256       end if;
6257
6258       --  Populate the two auxiliary tables used for dispatching asynchronous,
6259       --  conditional and timed selects for synchronized types that implement
6260       --  a limited interface. Skip this step in Ravenscar profile or when
6261       --  general dispatching is forbidden.
6262
6263       if Ada_Version >= Ada_2005
6264         and then Is_Concurrent_Record_Type (Typ)
6265         and then Has_Interfaces (Typ)
6266         and then not Restriction_Active (No_Dispatching_Calls)
6267         and then not Restriction_Active (No_Select_Statements)
6268       then
6269          Append_List_To (Result,
6270            Make_Select_Specific_Data_Table (Typ));
6271       end if;
6272
6273       --  Remember entities containing dispatch tables
6274
6275       Append_Elmt (Predef_Prims, DT_Decl);
6276       Append_Elmt (DT, DT_Decl);
6277
6278       Analyze_List (Result, Suppress => All_Checks);
6279       Set_Has_Dispatch_Table (Typ);
6280
6281       --  Mark entities containing dispatch tables. Required by the backend to
6282       --  handle them properly.
6283
6284       if Has_DT (Typ) then
6285          declare
6286             Elmt : Elmt_Id;
6287
6288          begin
6289             --  Object declarations
6290
6291             Elmt := First_Elmt (DT_Decl);
6292             while Present (Elmt) loop
6293                Set_Is_Dispatch_Table_Entity (Node (Elmt));
6294                pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
6295                  or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
6296                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6297                Next_Elmt (Elmt);
6298             end loop;
6299
6300             --  Aggregates initializing dispatch tables
6301
6302             Elmt := First_Elmt (DT_Aggr);
6303             while Present (Elmt) loop
6304                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6305                Next_Elmt (Elmt);
6306             end loop;
6307          end;
6308       end if;
6309
6310       --  Register the tagged type in the call graph nodes table
6311
6312       Register_CG_Node (Typ);
6313
6314       return Result;
6315    end Make_DT;
6316
6317    -----------------
6318    -- Make_VM_TSD --
6319    -----------------
6320
6321    function Make_VM_TSD (Typ : Entity_Id) return List_Id is
6322       Loc    : constant Source_Ptr := Sloc (Typ);
6323       Result : constant List_Id := New_List;
6324
6325       function Count_Primitives (Typ : Entity_Id) return Nat;
6326       --  Count the non-predefined primitive operations of Typ
6327
6328       ----------------------
6329       -- Count_Primitives --
6330       ----------------------
6331
6332       function Count_Primitives (Typ : Entity_Id) return Nat is
6333          Nb_Prim   : Nat;
6334          Prim_Elmt : Elmt_Id;
6335          Prim      : Entity_Id;
6336
6337       begin
6338          Nb_Prim := 0;
6339
6340          Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6341          while Present (Prim_Elmt) loop
6342             Prim := Node (Prim_Elmt);
6343
6344             if Is_Predefined_Dispatching_Operation (Prim)
6345               or else Is_Predefined_Dispatching_Alias (Prim)
6346             then
6347                null;
6348
6349             elsif Present (Interface_Alias (Prim)) then
6350                null;
6351
6352             else
6353                Nb_Prim := Nb_Prim + 1;
6354             end if;
6355
6356             Next_Elmt (Prim_Elmt);
6357          end loop;
6358
6359          return Nb_Prim;
6360       end Count_Primitives;
6361
6362       --------------
6363       -- Make_OSD --
6364       --------------
6365
6366       function Make_OSD (Iface : Entity_Id) return Node_Id;
6367       --  Generate the Object Specific Data table required to dispatch calls
6368       --  through synchronized interfaces. Returns a node that references the
6369       --  generated OSD object.
6370
6371       function Make_OSD (Iface : Entity_Id) return Node_Id is
6372          Nb_Prim       : constant Nat := Count_Primitives (Iface);
6373          OSD           : Entity_Id;
6374          OSD_Aggr_List : List_Id;
6375
6376       begin
6377          --  Generate
6378          --   OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
6379          --          (OSD_Table => (1 => <value>,
6380          --                           ...
6381          --                         N => <value>));
6382
6383          if Nb_Prim = 0
6384            or else Is_Abstract_Type (Typ)
6385            or else Is_Controlled (Typ)
6386            or else Restriction_Active (No_Dispatching_Calls)
6387            or else not Is_Limited_Type (Typ)
6388            or else not Has_Interfaces (Typ)
6389            or else not RTE_Record_Component_Available (RE_OSD_Table)
6390          then
6391             --  No OSD table required
6392
6393             return Make_Null (Loc);
6394
6395          else
6396             OSD_Aggr_List := New_List;
6397
6398             declare
6399                Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
6400                Prim       : Entity_Id;
6401                Prim_Alias : Entity_Id;
6402                Prim_Elmt  : Elmt_Id;
6403                E          : Entity_Id;
6404                Count      : Nat := 0;
6405                Pos        : Nat;
6406
6407             begin
6408                Prim_Table := (others => Empty);
6409                Prim_Alias := Empty;
6410
6411                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6412                while Present (Prim_Elmt) loop
6413                   Prim := Node (Prim_Elmt);
6414
6415                   if Present (Interface_Alias (Prim))
6416                     and then Find_Dispatching_Type
6417                                (Interface_Alias (Prim)) = Iface
6418                   then
6419                      Prim_Alias := Interface_Alias (Prim);
6420                      E   := Ultimate_Alias (Prim);
6421                      Pos := UI_To_Int (DT_Position (Prim_Alias));
6422
6423                      if Present (Prim_Table (Pos)) then
6424                         pragma Assert (Prim_Table (Pos) = E);
6425                         null;
6426
6427                      else
6428                         Prim_Table (Pos) := E;
6429
6430                         Append_To (OSD_Aggr_List,
6431                           Make_Component_Association (Loc,
6432                             Choices => New_List (
6433                               Make_Integer_Literal (Loc,
6434                                 DT_Position (Prim_Alias))),
6435                             Expression =>
6436                               Make_Integer_Literal (Loc,
6437                                 DT_Position (Alias (Prim)))));
6438
6439                         Count := Count + 1;
6440                      end if;
6441                   end if;
6442
6443                   Next_Elmt (Prim_Elmt);
6444                end loop;
6445                pragma Assert (Count = Nb_Prim);
6446             end;
6447
6448             OSD := Make_Temporary (Loc, 'I');
6449
6450             Append_To (Result,
6451               Make_Object_Declaration (Loc,
6452                 Defining_Identifier => OSD,
6453                 Aliased_Present     => True,
6454                 Constant_Present    => True,
6455                 Object_Definition   =>
6456                   Make_Subtype_Indication (Loc,
6457                     Subtype_Mark =>
6458                       New_Reference_To (RTE (RE_Object_Specific_Data), Loc),
6459                     Constraint =>
6460                       Make_Index_Or_Discriminant_Constraint (Loc,
6461                         Constraints => New_List (
6462                           Make_Integer_Literal (Loc, Nb_Prim)))),
6463
6464                 Expression          =>
6465                   Make_Aggregate (Loc,
6466                     Component_Associations => New_List (
6467                       Make_Component_Association (Loc,
6468                         Choices => New_List (
6469                           New_Occurrence_Of
6470                             (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
6471                         Expression =>
6472                           Make_Integer_Literal (Loc, Nb_Prim)),
6473
6474                       Make_Component_Association (Loc,
6475                         Choices => New_List (
6476                           New_Occurrence_Of
6477                             (RTE_Record_Component (RE_OSD_Table), Loc)),
6478                         Expression => Make_Aggregate (Loc,
6479                           Component_Associations => OSD_Aggr_List))))));
6480
6481             return
6482               Make_Attribute_Reference (Loc,
6483                 Prefix => New_Reference_To (OSD, Loc),
6484                 Attribute_Name => Name_Unchecked_Access);
6485          end if;
6486       end Make_OSD;
6487
6488       --  Local variables
6489
6490       Nb_Prim          : constant Nat := Count_Primitives (Typ);
6491       AI               : Elmt_Id;
6492       I_Depth          : Nat;
6493       Iface_Table_Node : Node_Id;
6494       Num_Ifaces       : Nat;
6495       TSD_Aggr_List    : List_Id;
6496       Typ_Ifaces       : Elist_Id;
6497       TSD_Tags_List    : List_Id;
6498
6499       Tname    : constant Name_Id := Chars (Typ);
6500       Name_SSD : constant Name_Id :=
6501                    New_External_Name (Tname, 'S', Suffix_Index => -1);
6502       Name_TSD : constant Name_Id :=
6503                    New_External_Name (Tname, 'B', Suffix_Index => -1);
6504       SSD      : constant Entity_Id :=
6505                    Make_Defining_Identifier (Loc, Name_SSD);
6506       TSD      : constant Entity_Id :=
6507                    Make_Defining_Identifier (Loc, Name_TSD);
6508    begin
6509       --  Generate code to create the storage for the type specific data object
6510       --  with enough space to store the tags of the ancestors plus the tags
6511       --  of all the implemented interfaces (as described in a-tags.ads).
6512
6513       --   TSD : Type_Specific_Data (I_Depth) :=
6514       --           (Idepth                => I_Depth,
6515       --            Tag_Kind              => <tag_kind-value>,
6516       --            Access_Level          => Type_Access_Level (Typ),
6517       --            Alignment             => Typ'Alignment,
6518       --            HT_Link               => null,
6519       --            Type_Is_Abstract      => <<boolean-value>>,
6520       --            Type_Is_Library_Level => <<boolean-value>>,
6521       --            Interfaces_Table      => <<access-value>>
6522       --            SSD                   => SSD_Table'Address
6523       --            Tags_Table            => (0 => Typ'Tag,
6524       --                                      1 => Parent'Tag
6525       --                                      ...));
6526
6527       TSD_Aggr_List := New_List;
6528
6529       --  Idepth: Count ancestors to compute the inheritance depth. For private
6530       --  extensions, always go to the full view in order to compute the real
6531       --  inheritance depth.
6532
6533       declare
6534          Current_Typ : Entity_Id;
6535          Parent_Typ  : Entity_Id;
6536
6537       begin
6538          I_Depth     := 0;
6539          Current_Typ := Typ;
6540          loop
6541             Parent_Typ := Etype (Current_Typ);
6542
6543             if Is_Private_Type (Parent_Typ) then
6544                Parent_Typ := Full_View (Base_Type (Parent_Typ));
6545             end if;
6546
6547             exit when Parent_Typ = Current_Typ;
6548
6549             I_Depth := I_Depth + 1;
6550             Current_Typ := Parent_Typ;
6551          end loop;
6552       end;
6553
6554       --  I_Depth
6555
6556       Append_To (TSD_Aggr_List,
6557         Make_Integer_Literal (Loc, I_Depth));
6558
6559       --  Tag_Kind
6560
6561       Append_To (TSD_Aggr_List, Tagged_Kind (Typ));
6562
6563       --  Access_Level
6564
6565       Append_To (TSD_Aggr_List,
6566         Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
6567
6568       --  Alignment
6569
6570       --  For CPP types we cannot rely on the value of 'Alignment provided
6571       --  by the backend to initialize this TSD field. Why not???
6572
6573       if Convention (Typ) = Convention_CPP
6574         or else Is_CPP_Class (Root_Type (Typ))
6575       then
6576          Append_To (TSD_Aggr_List,
6577            Make_Integer_Literal (Loc, 0));
6578       else
6579          Append_To (TSD_Aggr_List,
6580            Make_Attribute_Reference (Loc,
6581              Prefix         => New_Reference_To (Typ, Loc),
6582              Attribute_Name => Name_Alignment));
6583       end if;
6584
6585       --  HT_Link
6586
6587       Append_To (TSD_Aggr_List,
6588         Make_Null (Loc));
6589
6590       --  Type_Is_Abstract (Ada 2012: AI05-0173)
6591
6592       declare
6593          Type_Is_Abstract : Entity_Id;
6594
6595       begin
6596          Type_Is_Abstract :=
6597            Boolean_Literals (Is_Abstract_Type (Typ));
6598
6599          Append_To (TSD_Aggr_List,
6600             New_Occurrence_Of (Type_Is_Abstract, Loc));
6601       end;
6602
6603       --  Type_Is_Library_Level
6604
6605       declare
6606          Type_Is_Library_Level : Entity_Id;
6607       begin
6608          Type_Is_Library_Level :=
6609            Boolean_Literals (Is_Library_Level_Entity (Typ));
6610          Append_To (TSD_Aggr_List,
6611             New_Occurrence_Of (Type_Is_Library_Level, Loc));
6612       end;
6613
6614       --  Interfaces_Table (required for AI-405)
6615
6616       if RTE_Record_Component_Available (RE_Interfaces_Table) then
6617
6618          --  Count the number of interface types implemented by Typ
6619
6620          Collect_Interfaces (Typ, Typ_Ifaces);
6621
6622          Num_Ifaces := 0;
6623          AI := First_Elmt (Typ_Ifaces);
6624          while Present (AI) loop
6625             Num_Ifaces := Num_Ifaces + 1;
6626             Next_Elmt (AI);
6627          end loop;
6628
6629          if Num_Ifaces = 0 then
6630             Iface_Table_Node := Make_Null (Loc);
6631
6632          --  Generate the Interface_Table object
6633
6634          else
6635             declare
6636                TSD_Ifaces_List : constant List_Id := New_List;
6637                Iface           : Entity_Id;
6638                ITable          : Node_Id;
6639
6640             begin
6641                AI := First_Elmt (Typ_Ifaces);
6642                while Present (AI) loop
6643                   Iface := Node (AI);
6644
6645                   Append_To (TSD_Ifaces_List,
6646                      Make_Aggregate (Loc,
6647                        Expressions => New_List (
6648
6649                          --  Iface_Tag
6650
6651                          Make_Attribute_Reference (Loc,
6652                            Prefix         => New_Reference_To (Iface, Loc),
6653                            Attribute_Name => Name_Tag),
6654
6655                          --  OSD
6656
6657                          Make_OSD (Iface))));
6658
6659                   Next_Elmt (AI);
6660                end loop;
6661
6662                ITable := Make_Temporary (Loc, 'I');
6663
6664                Append_To (Result,
6665                  Make_Object_Declaration (Loc,
6666                    Defining_Identifier => ITable,
6667                    Aliased_Present     => True,
6668                    Constant_Present    => True,
6669                    Object_Definition   =>
6670                      Make_Subtype_Indication (Loc,
6671                        Subtype_Mark =>
6672                          New_Reference_To (RTE (RE_Interface_Data), Loc),
6673                        Constraint   => Make_Index_Or_Discriminant_Constraint
6674                          (Loc,
6675                           Constraints => New_List (
6676                             Make_Integer_Literal (Loc, Num_Ifaces)))),
6677
6678                    Expression => Make_Aggregate (Loc,
6679                      Expressions => New_List (
6680                        Make_Integer_Literal (Loc, Num_Ifaces),
6681                        Make_Aggregate (Loc,
6682                          Expressions => TSD_Ifaces_List)))));
6683
6684                Iface_Table_Node :=
6685                  Make_Attribute_Reference (Loc,
6686                    Prefix         => New_Reference_To (ITable, Loc),
6687                    Attribute_Name => Name_Unchecked_Access);
6688             end;
6689          end if;
6690
6691          Append_To (TSD_Aggr_List, Iface_Table_Node);
6692       end if;
6693
6694       --  Generate the Select Specific Data table for synchronized types that
6695       --  implement synchronized interfaces. The size of the table is
6696       --  constrained by the number of non-predefined primitive operations.
6697
6698       if RTE_Record_Component_Available (RE_SSD) then
6699          if Ada_Version >= Ada_2005
6700            and then Has_DT (Typ)
6701            and then Is_Concurrent_Record_Type (Typ)
6702            and then Has_Interfaces (Typ)
6703            and then Nb_Prim > 0
6704            and then not Is_Abstract_Type (Typ)
6705            and then not Is_Controlled (Typ)
6706            and then not Restriction_Active (No_Dispatching_Calls)
6707            and then not Restriction_Active (No_Select_Statements)
6708          then
6709             Append_To (Result,
6710               Make_Object_Declaration (Loc,
6711                 Defining_Identifier => SSD,
6712                 Aliased_Present     => True,
6713                 Object_Definition   =>
6714                   Make_Subtype_Indication (Loc,
6715                     Subtype_Mark => New_Reference_To (
6716                       RTE (RE_Select_Specific_Data), Loc),
6717                     Constraint   =>
6718                       Make_Index_Or_Discriminant_Constraint (Loc,
6719                         Constraints => New_List (
6720                           Make_Integer_Literal (Loc, Nb_Prim))))));
6721
6722             --  This table is initialized by Make_Select_Specific_Data_Table,
6723             --  which calls Set_Entry_Index and Set_Prim_Op_Kind.
6724
6725             Append_To (TSD_Aggr_List,
6726               Make_Attribute_Reference (Loc,
6727                 Prefix         => New_Reference_To (SSD, Loc),
6728                 Attribute_Name => Name_Unchecked_Access));
6729          else
6730             Append_To (TSD_Aggr_List, Make_Null (Loc));
6731          end if;
6732       end if;
6733
6734       --  Initialize the table of ancestor tags. In case of interface types
6735       --  this table is not needed.
6736
6737       TSD_Tags_List := New_List;
6738
6739       --  Fill position 0 with Typ'Tag
6740
6741       Append_To (TSD_Tags_List,
6742         Make_Attribute_Reference (Loc,
6743           Prefix         => New_Reference_To (Typ, Loc),
6744           Attribute_Name => Name_Tag));
6745
6746       --  Fill the rest of the table with the tags of the ancestors
6747
6748       declare
6749          Current_Typ : Entity_Id;
6750          Parent_Typ  : Entity_Id;
6751          Pos         : Nat;
6752
6753       begin
6754          Pos := 1;
6755          Current_Typ := Typ;
6756
6757          loop
6758             Parent_Typ := Etype (Current_Typ);
6759
6760             if Is_Private_Type (Parent_Typ) then
6761                Parent_Typ := Full_View (Base_Type (Parent_Typ));
6762             end if;
6763
6764             exit when Parent_Typ = Current_Typ;
6765
6766             Append_To (TSD_Tags_List,
6767               Make_Attribute_Reference (Loc,
6768                 Prefix         => New_Reference_To (Parent_Typ, Loc),
6769                 Attribute_Name => Name_Tag));
6770
6771             Pos := Pos + 1;
6772             Current_Typ := Parent_Typ;
6773          end loop;
6774
6775          pragma Assert (Pos = I_Depth + 1);
6776       end;
6777
6778       Append_To (TSD_Aggr_List,
6779         Make_Aggregate (Loc,
6780           Expressions => TSD_Tags_List));
6781
6782       --  Build the TSD object
6783
6784       Append_To (Result,
6785         Make_Object_Declaration (Loc,
6786           Defining_Identifier => TSD,
6787           Aliased_Present     => True,
6788           Constant_Present    => True,
6789           Object_Definition   =>
6790             Make_Subtype_Indication (Loc,
6791               Subtype_Mark => New_Reference_To (
6792                 RTE (RE_Type_Specific_Data), Loc),
6793               Constraint =>
6794                 Make_Index_Or_Discriminant_Constraint (Loc,
6795                   Constraints => New_List (
6796                     Make_Integer_Literal (Loc, I_Depth)))),
6797
6798           Expression => Make_Aggregate (Loc,
6799             Expressions => TSD_Aggr_List)));
6800
6801       --  Generate:
6802       --     Check_TSD
6803       --       (TSD => TSD'Unrestricted_Access);
6804
6805       if Ada_Version >= Ada_2005
6806         and then Is_Library_Level_Entity (Typ)
6807         and then Has_External_Tag_Rep_Clause (Typ)
6808         and then RTE_Available (RE_Check_TSD)
6809         and then not Debug_Flag_QQ
6810       then
6811          Append_To (Result,
6812            Make_Procedure_Call_Statement (Loc,
6813              Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
6814              Parameter_Associations => New_List (
6815                Make_Attribute_Reference (Loc,
6816                  Prefix         => New_Reference_To (TSD, Loc),
6817                  Attribute_Name => Name_Unrestricted_Access))));
6818       end if;
6819
6820       --  Generate:
6821       --     Register_TSD (TSD'Unrestricted_Access);
6822
6823       Append_To (Result,
6824         Make_Procedure_Call_Statement (Loc,
6825           Name => New_Reference_To (RTE (RE_Register_TSD), Loc),
6826           Parameter_Associations => New_List (
6827             Make_Attribute_Reference (Loc,
6828               Prefix         => New_Reference_To (TSD, Loc),
6829               Attribute_Name => Name_Unrestricted_Access))));
6830
6831       --  Populate the two auxiliary tables used for dispatching asynchronous,
6832       --  conditional and timed selects for synchronized types that implement
6833       --  a limited interface. Skip this step in Ravenscar profile or when
6834       --  general dispatching is forbidden.
6835
6836       if Ada_Version >= Ada_2005
6837         and then Is_Concurrent_Record_Type (Typ)
6838         and then Has_Interfaces (Typ)
6839         and then not Restriction_Active (No_Dispatching_Calls)
6840         and then not Restriction_Active (No_Select_Statements)
6841       then
6842          Append_List_To (Result,
6843            Make_Select_Specific_Data_Table (Typ));
6844       end if;
6845
6846       return Result;
6847    end Make_VM_TSD;
6848
6849    -------------------------------------
6850    -- Make_Select_Specific_Data_Table --
6851    -------------------------------------
6852
6853    function Make_Select_Specific_Data_Table
6854      (Typ : Entity_Id) return List_Id
6855    is
6856       Assignments : constant List_Id    := New_List;
6857       Loc         : constant Source_Ptr := Sloc (Typ);
6858
6859       Conc_Typ  : Entity_Id;
6860       Decls     : List_Id;
6861       Prim      : Entity_Id;
6862       Prim_Als  : Entity_Id;
6863       Prim_Elmt : Elmt_Id;
6864       Prim_Pos  : Uint;
6865       Nb_Prim   : Nat := 0;
6866
6867       type Examined_Array is array (Int range <>) of Boolean;
6868
6869       function Find_Entry_Index (E : Entity_Id) return Uint;
6870       --  Given an entry, find its index in the visible declarations of the
6871       --  corresponding concurrent type of Typ.
6872
6873       ----------------------
6874       -- Find_Entry_Index --
6875       ----------------------
6876
6877       function Find_Entry_Index (E : Entity_Id) return Uint is
6878          Index     : Uint := Uint_1;
6879          Subp_Decl : Entity_Id;
6880
6881       begin
6882          if Present (Decls)
6883            and then not Is_Empty_List (Decls)
6884          then
6885             Subp_Decl := First (Decls);
6886             while Present (Subp_Decl) loop
6887                if Nkind (Subp_Decl) = N_Entry_Declaration then
6888                   if Defining_Identifier (Subp_Decl) = E then
6889                      return Index;
6890                   end if;
6891
6892                   Index := Index + 1;
6893                end if;
6894
6895                Next (Subp_Decl);
6896             end loop;
6897          end if;
6898
6899          return Uint_0;
6900       end Find_Entry_Index;
6901
6902       --  Local variables
6903
6904       Tag_Node : Node_Id;
6905
6906    --  Start of processing for Make_Select_Specific_Data_Table
6907
6908    begin
6909       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6910
6911       if Present (Corresponding_Concurrent_Type (Typ)) then
6912          Conc_Typ := Corresponding_Concurrent_Type (Typ);
6913
6914          if Present (Full_View (Conc_Typ)) then
6915             Conc_Typ := Full_View (Conc_Typ);
6916          end if;
6917
6918          if Ekind (Conc_Typ) = E_Protected_Type then
6919             Decls := Visible_Declarations (Protected_Definition (
6920                        Parent (Conc_Typ)));
6921          else
6922             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6923             Decls := Visible_Declarations (Task_Definition (
6924                        Parent (Conc_Typ)));
6925          end if;
6926       end if;
6927
6928       --  Count the non-predefined primitive operations
6929
6930       Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6931       while Present (Prim_Elmt) loop
6932          Prim := Node (Prim_Elmt);
6933
6934          if not (Is_Predefined_Dispatching_Operation (Prim)
6935                    or else Is_Predefined_Dispatching_Alias (Prim))
6936          then
6937             Nb_Prim := Nb_Prim + 1;
6938          end if;
6939
6940          Next_Elmt (Prim_Elmt);
6941       end loop;
6942
6943       declare
6944          Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
6945
6946       begin
6947          Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6948          while Present (Prim_Elmt) loop
6949             Prim := Node (Prim_Elmt);
6950
6951             --  Look for primitive overriding an abstract interface subprogram
6952
6953             if Present (Interface_Alias (Prim))
6954               and then not
6955                 Is_Ancestor
6956                   (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
6957                    Use_Full_View => True)
6958               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
6959             then
6960                Prim_Pos := DT_Position (Alias (Prim));
6961                pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
6962                Examined (UI_To_Int (Prim_Pos)) := True;
6963
6964                --  Set the primitive operation kind regardless of subprogram
6965                --  type. Generate:
6966                --    Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6967
6968                if Tagged_Type_Expansion then
6969                   Tag_Node :=
6970                     New_Reference_To
6971                      (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6972
6973                else
6974                   Tag_Node :=
6975                     Make_Attribute_Reference (Loc,
6976                       Prefix         => New_Reference_To (Typ, Loc),
6977                       Attribute_Name => Name_Tag);
6978                end if;
6979
6980                Append_To (Assignments,
6981                  Make_Procedure_Call_Statement (Loc,
6982                    Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
6983                    Parameter_Associations => New_List (
6984                      Tag_Node,
6985                      Make_Integer_Literal (Loc, Prim_Pos),
6986                      Prim_Op_Kind (Alias (Prim), Typ))));
6987
6988                --  Retrieve the root of the alias chain
6989
6990                Prim_Als := Ultimate_Alias (Prim);
6991
6992                --  In the case of an entry wrapper, set the entry index
6993
6994                if Ekind (Prim) = E_Procedure
6995                  and then Is_Primitive_Wrapper (Prim_Als)
6996                  and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
6997                then
6998                   --  Generate:
6999                   --    Ada.Tags.Set_Entry_Index
7000                   --      (DT_Ptr, <position>, <index>);
7001
7002                   if Tagged_Type_Expansion then
7003                      Tag_Node :=
7004                        New_Reference_To
7005                          (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
7006                   else
7007                      Tag_Node :=
7008                        Make_Attribute_Reference (Loc,
7009                          Prefix         => New_Reference_To (Typ, Loc),
7010                          Attribute_Name => Name_Tag);
7011                   end if;
7012
7013                   Append_To (Assignments,
7014                     Make_Procedure_Call_Statement (Loc,
7015                       Name =>
7016                         New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
7017                       Parameter_Associations => New_List (
7018                         Tag_Node,
7019                         Make_Integer_Literal (Loc, Prim_Pos),
7020                         Make_Integer_Literal (Loc,
7021                           Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
7022                end if;
7023             end if;
7024
7025             Next_Elmt (Prim_Elmt);
7026          end loop;
7027       end;
7028
7029       return Assignments;
7030    end Make_Select_Specific_Data_Table;
7031
7032    ---------------
7033    -- Make_Tags --
7034    ---------------
7035
7036    function Make_Tags (Typ : Entity_Id) return List_Id is
7037       Loc    : constant Source_Ptr := Sloc (Typ);
7038       Result : constant List_Id    := New_List;
7039
7040       procedure Import_DT
7041         (Tag_Typ         : Entity_Id;
7042          DT              : Entity_Id;
7043          Is_Secondary_DT : Boolean);
7044       --  Import the dispatch table DT of tagged type Tag_Typ. Required to
7045       --  generate forward references and statically allocate the table. For
7046       --  primary dispatch tables that require no dispatch table generate:
7047
7048       --     DT : static aliased constant Non_Dispatch_Table_Wrapper;
7049       --     pragma Import (Ada, DT);
7050
7051       --  Otherwise generate:
7052
7053       --     DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
7054       --     pragma Import (Ada, DT);
7055
7056       ---------------
7057       -- Import_DT --
7058       ---------------
7059
7060       procedure Import_DT
7061         (Tag_Typ         : Entity_Id;
7062          DT              : Entity_Id;
7063          Is_Secondary_DT : Boolean)
7064       is
7065          DT_Constr_List : List_Id;
7066          Nb_Prim        : Nat;
7067
7068       begin
7069          Set_Is_Imported  (DT);
7070          Set_Ekind        (DT, E_Constant);
7071          Set_Related_Type (DT, Typ);
7072
7073          --  The scope must be set now to call Get_External_Name
7074
7075          Set_Scope (DT, Current_Scope);
7076
7077          Get_External_Name (DT, True);
7078          Set_Interface_Name (DT,
7079            Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
7080
7081          --  Ensure proper Sprint output of this implicit importation
7082
7083          Set_Is_Internal (DT);
7084
7085          --  Save this entity to allow Make_DT to generate its exportation
7086
7087          Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
7088
7089          --  No dispatch table required
7090
7091          if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then
7092             Append_To (Result,
7093               Make_Object_Declaration (Loc,
7094                 Defining_Identifier => DT,
7095                 Aliased_Present     => True,
7096                 Constant_Present    => True,
7097                 Object_Definition   =>
7098                   New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
7099
7100          else
7101             --  Calculate the number of primitives of the dispatch table and
7102             --  the size of the Type_Specific_Data record.
7103
7104             Nb_Prim :=
7105               UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
7106
7107             --  If the tagged type has no primitives we add a dummy slot whose
7108             --  address will be the tag of this type.
7109
7110             if Nb_Prim = 0 then
7111                DT_Constr_List :=
7112                  New_List (Make_Integer_Literal (Loc, 1));
7113             else
7114                DT_Constr_List :=
7115                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
7116             end if;
7117
7118             Append_To (Result,
7119               Make_Object_Declaration (Loc,
7120                 Defining_Identifier => DT,
7121                 Aliased_Present     => True,
7122                 Constant_Present    => True,
7123                 Object_Definition   =>
7124                   Make_Subtype_Indication (Loc,
7125                     Subtype_Mark =>
7126                       New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
7127                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
7128                                     Constraints => DT_Constr_List))));
7129          end if;
7130       end Import_DT;
7131
7132       --  Local variables
7133
7134       Tname            : constant Name_Id := Chars (Typ);
7135       AI_Tag_Comp      : Elmt_Id;
7136       DT               : Node_Id := Empty;
7137       DT_Ptr           : Node_Id;
7138       Predef_Prims_Ptr : Node_Id;
7139       Iface_DT         : Node_Id := Empty;
7140       Iface_DT_Ptr     : Node_Id;
7141       New_Node         : Node_Id;
7142       Suffix_Index     : Int;
7143       Typ_Name         : Name_Id;
7144       Typ_Comps        : Elist_Id;
7145
7146    --  Start of processing for Make_Tags
7147
7148    begin
7149       pragma Assert (No (Access_Disp_Table (Typ)));
7150       Set_Access_Disp_Table (Typ, New_Elmt_List);
7151
7152       --  1) Generate the primary tag entities
7153
7154       --  Primary dispatch table containing user-defined primitives
7155
7156       DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
7157       Set_Etype   (DT_Ptr, RTE (RE_Tag));
7158       Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
7159
7160       --  Minimum decoration
7161
7162       Set_Ekind        (DT_Ptr, E_Variable);
7163       Set_Related_Type (DT_Ptr, Typ);
7164
7165       --  Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
7166       --  the decoration required by the backend.
7167
7168       --  Odd comment, the back end cannot require anything not properly
7169       --  documented in einfo! ???
7170
7171       Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
7172       Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
7173
7174       --  For CPP types there is no need to build the dispatch tables since
7175       --  they are imported from the C++ side. If the CPP type has an IP then
7176       --  we declare now the variable that will store the copy of the C++ tag.
7177       --  If the CPP type is an interface, we need the variable as well because
7178       --  it becomes the pointer to the corresponding secondary table.
7179
7180       if Is_CPP_Class (Typ) then
7181          if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then
7182             Append_To (Result,
7183               Make_Object_Declaration (Loc,
7184                 Defining_Identifier => DT_Ptr,
7185                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
7186                 Expression =>
7187                   Unchecked_Convert_To (RTE (RE_Tag),
7188                     New_Reference_To (RTE (RE_Null_Address), Loc))));
7189
7190             Set_Is_Statically_Allocated (DT_Ptr,
7191               Is_Library_Level_Tagged_Type (Typ));
7192          end if;
7193
7194       --  Ada types
7195
7196       else
7197          --  Primary dispatch table containing predefined primitives
7198
7199          Predef_Prims_Ptr :=
7200            Make_Defining_Identifier (Loc,
7201              Chars => New_External_Name (Tname, 'Y'));
7202          Set_Etype   (Predef_Prims_Ptr, RTE (RE_Address));
7203          Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
7204
7205          --  Import the forward declaration of the Dispatch Table wrapper
7206          --  record (Make_DT will take care of exporting it).
7207
7208          if Building_Static_DT (Typ) then
7209             Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
7210
7211             DT :=
7212               Make_Defining_Identifier (Loc,
7213                 Chars => New_External_Name (Tname, 'T'));
7214
7215             Import_DT (Typ, DT, Is_Secondary_DT => False);
7216
7217             if Has_DT (Typ) then
7218                Append_To (Result,
7219                  Make_Object_Declaration (Loc,
7220                    Defining_Identifier => DT_Ptr,
7221                    Constant_Present    => True,
7222                    Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
7223                    Expression          =>
7224                      Unchecked_Convert_To (RTE (RE_Tag),
7225                        Make_Attribute_Reference (Loc,
7226                          Prefix         =>
7227                            Make_Selected_Component (Loc,
7228                              Prefix        => New_Reference_To (DT, Loc),
7229                              Selector_Name =>
7230                                New_Occurrence_Of
7231                                  (RTE_Record_Component (RE_Prims_Ptr), Loc)),
7232                          Attribute_Name => Name_Address))));
7233
7234                --  Generate the SCIL node for the previous object declaration
7235                --  because it has a tag initialization.
7236
7237                if Generate_SCIL then
7238                   New_Node :=
7239                     Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
7240                   Set_SCIL_Entity (New_Node, Typ);
7241                   Set_SCIL_Node (Last (Result), New_Node);
7242                end if;
7243
7244                Append_To (Result,
7245                  Make_Object_Declaration (Loc,
7246                    Defining_Identifier => Predef_Prims_Ptr,
7247                    Constant_Present    => True,
7248                    Object_Definition   =>
7249                      New_Reference_To (RTE (RE_Address), Loc),
7250                    Expression          =>
7251                      Make_Attribute_Reference (Loc,
7252                        Prefix         =>
7253                          Make_Selected_Component (Loc,
7254                            Prefix        => New_Reference_To (DT, Loc),
7255                            Selector_Name =>
7256                              New_Occurrence_Of
7257                                (RTE_Record_Component (RE_Predef_Prims), Loc)),
7258                        Attribute_Name => Name_Address)));
7259
7260             --  No dispatch table required
7261
7262             else
7263                Append_To (Result,
7264                  Make_Object_Declaration (Loc,
7265                    Defining_Identifier => DT_Ptr,
7266                    Constant_Present    => True,
7267                    Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
7268                    Expression          =>
7269                      Unchecked_Convert_To (RTE (RE_Tag),
7270                        Make_Attribute_Reference (Loc,
7271                          Prefix         =>
7272                            Make_Selected_Component (Loc,
7273                              Prefix => New_Reference_To (DT, Loc),
7274                              Selector_Name =>
7275                                New_Occurrence_Of
7276                                  (RTE_Record_Component (RE_NDT_Prims_Ptr),
7277                                   Loc)),
7278                          Attribute_Name => Name_Address))));
7279             end if;
7280
7281             Set_Is_True_Constant (DT_Ptr);
7282             Set_Is_Statically_Allocated (DT_Ptr);
7283          end if;
7284       end if;
7285
7286       --  2) Generate the secondary tag entities
7287
7288       --  Collect the components associated with secondary dispatch tables
7289
7290       if Has_Interfaces (Typ) then
7291          Collect_Interface_Components (Typ, Typ_Comps);
7292
7293          --  For each interface type we build a unique external name associated
7294          --  with its secondary dispatch table. This name is used to declare an
7295          --  object that references this secondary dispatch table, whose value
7296          --  will be used for the elaboration of Typ objects, and also for the
7297          --  elaboration of objects of types derived from Typ that do not
7298          --  override the primitives of this interface type.
7299
7300          Suffix_Index := 1;
7301
7302          --  Note: The value of Suffix_Index must be in sync with the
7303          --  Suffix_Index values of secondary dispatch tables generated
7304          --  by Make_DT.
7305
7306          if Is_CPP_Class (Typ) then
7307             AI_Tag_Comp := First_Elmt (Typ_Comps);
7308             while Present (AI_Tag_Comp) loop
7309                Get_Secondary_DT_External_Name
7310                  (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7311                Typ_Name := Name_Find;
7312
7313                --  Declare variables that will store the copy of the C++
7314                --  secondary tags.
7315
7316                Iface_DT_Ptr :=
7317                  Make_Defining_Identifier (Loc,
7318                    Chars => New_External_Name (Typ_Name, 'P'));
7319                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7320                Set_Ekind (Iface_DT_Ptr, E_Variable);
7321                Set_Is_Tag (Iface_DT_Ptr);
7322
7323                Set_Has_Thunks (Iface_DT_Ptr);
7324                Set_Related_Type
7325                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7326                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7327
7328                Append_To (Result,
7329                  Make_Object_Declaration (Loc,
7330                    Defining_Identifier => Iface_DT_Ptr,
7331                    Object_Definition   => New_Reference_To
7332                                             (RTE (RE_Interface_Tag), Loc),
7333                    Expression =>
7334                      Unchecked_Convert_To (RTE (RE_Interface_Tag),
7335                        New_Reference_To (RTE (RE_Null_Address), Loc))));
7336
7337                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7338                  Is_Library_Level_Tagged_Type (Typ));
7339
7340                Next_Elmt (AI_Tag_Comp);
7341             end loop;
7342
7343          --  This is not a CPP_Class type
7344
7345          else
7346             AI_Tag_Comp := First_Elmt (Typ_Comps);
7347             while Present (AI_Tag_Comp) loop
7348                Get_Secondary_DT_External_Name
7349                  (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7350                Typ_Name := Name_Find;
7351
7352                if Building_Static_DT (Typ) then
7353                   Iface_DT :=
7354                     Make_Defining_Identifier (Loc,
7355                       Chars => New_External_Name
7356                                  (Typ_Name, 'T', Suffix_Index => -1));
7357                   Import_DT
7358                     (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
7359                      DT      => Iface_DT,
7360                      Is_Secondary_DT => True);
7361                end if;
7362
7363                --  Secondary dispatch table referencing thunks to user-defined
7364                --  primitives covered by this interface.
7365
7366                Iface_DT_Ptr :=
7367                  Make_Defining_Identifier (Loc,
7368                    Chars => New_External_Name (Typ_Name, 'P'));
7369                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7370                Set_Ekind (Iface_DT_Ptr, E_Constant);
7371                Set_Is_Tag (Iface_DT_Ptr);
7372                Set_Has_Thunks (Iface_DT_Ptr);
7373                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7374                  Is_Library_Level_Tagged_Type (Typ));
7375                Set_Is_True_Constant (Iface_DT_Ptr);
7376                Set_Related_Type
7377                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7378                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7379
7380                if Building_Static_DT (Typ) then
7381                   Append_To (Result,
7382                     Make_Object_Declaration (Loc,
7383                       Defining_Identifier => Iface_DT_Ptr,
7384                       Constant_Present    => True,
7385                       Object_Definition   => New_Reference_To
7386                                                (RTE (RE_Interface_Tag), Loc),
7387                       Expression          =>
7388                         Unchecked_Convert_To (RTE (RE_Interface_Tag),
7389                           Make_Attribute_Reference (Loc,
7390                             Prefix         =>
7391                               Make_Selected_Component (Loc,
7392                                 Prefix        =>
7393                                   New_Reference_To (Iface_DT, Loc),
7394                                 Selector_Name =>
7395                                   New_Occurrence_Of
7396                                     (RTE_Record_Component (RE_Prims_Ptr),
7397                                      Loc)),
7398                             Attribute_Name => Name_Address))));
7399                end if;
7400
7401                --  Secondary dispatch table referencing thunks to predefined
7402                --  primitives.
7403
7404                Iface_DT_Ptr :=
7405                  Make_Defining_Identifier (Loc,
7406                    Chars => New_External_Name (Typ_Name, 'Y'));
7407                Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7408                Set_Ekind (Iface_DT_Ptr, E_Constant);
7409                Set_Is_Tag (Iface_DT_Ptr);
7410                Set_Has_Thunks (Iface_DT_Ptr);
7411                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7412                  Is_Library_Level_Tagged_Type (Typ));
7413                Set_Is_True_Constant (Iface_DT_Ptr);
7414                Set_Related_Type
7415                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7416                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7417
7418                --  Secondary dispatch table referencing user-defined primitives
7419                --  covered by this interface.
7420
7421                Iface_DT_Ptr :=
7422                  Make_Defining_Identifier (Loc,
7423                    Chars => New_External_Name (Typ_Name, 'D'));
7424                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7425                Set_Ekind (Iface_DT_Ptr, E_Constant);
7426                Set_Is_Tag (Iface_DT_Ptr);
7427                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7428                  Is_Library_Level_Tagged_Type (Typ));
7429                Set_Is_True_Constant (Iface_DT_Ptr);
7430                Set_Related_Type
7431                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7432                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7433
7434                --  Secondary dispatch table referencing predefined primitives
7435
7436                Iface_DT_Ptr :=
7437                  Make_Defining_Identifier (Loc,
7438                    Chars => New_External_Name (Typ_Name, 'Z'));
7439                Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7440                Set_Ekind (Iface_DT_Ptr, E_Constant);
7441                Set_Is_Tag (Iface_DT_Ptr);
7442                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7443                  Is_Library_Level_Tagged_Type (Typ));
7444                Set_Is_True_Constant (Iface_DT_Ptr);
7445                Set_Related_Type
7446                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7447                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7448
7449                Next_Elmt (AI_Tag_Comp);
7450             end loop;
7451          end if;
7452       end if;
7453
7454       --  3) At the end of Access_Disp_Table, if the type has user-defined
7455       --     primitives, we add the entity of an access type declaration that
7456       --     is used by Build_Get_Prim_Op_Address to expand dispatching calls
7457       --     through the primary dispatch table.
7458
7459       if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
7460          Analyze_List (Result);
7461
7462       --     Generate:
7463       --       type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
7464       --       type Typ_DT_Acc is access Typ_DT;
7465
7466       else
7467          declare
7468             Name_DT_Prims     : constant Name_Id :=
7469                                   New_External_Name (Tname, 'G');
7470             Name_DT_Prims_Acc : constant Name_Id :=
7471                                   New_External_Name (Tname, 'H');
7472             DT_Prims          : constant Entity_Id :=
7473                                   Make_Defining_Identifier (Loc,
7474                                     Name_DT_Prims);
7475             DT_Prims_Acc      : constant Entity_Id :=
7476                                   Make_Defining_Identifier (Loc,
7477                                     Name_DT_Prims_Acc);
7478          begin
7479             Append_To (Result,
7480               Make_Full_Type_Declaration (Loc,
7481                 Defining_Identifier => DT_Prims,
7482                 Type_Definition =>
7483                   Make_Constrained_Array_Definition (Loc,
7484                     Discrete_Subtype_Definitions => New_List (
7485                       Make_Range (Loc,
7486                         Low_Bound  => Make_Integer_Literal (Loc, 1),
7487                         High_Bound => Make_Integer_Literal (Loc,
7488                                        DT_Entry_Count
7489                                          (First_Tag_Component (Typ))))),
7490                     Component_Definition =>
7491                       Make_Component_Definition (Loc,
7492                         Subtype_Indication =>
7493                           New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
7494
7495             Append_To (Result,
7496               Make_Full_Type_Declaration (Loc,
7497                 Defining_Identifier => DT_Prims_Acc,
7498                 Type_Definition =>
7499                    Make_Access_To_Object_Definition (Loc,
7500                      Subtype_Indication =>
7501                        New_Occurrence_Of (DT_Prims, Loc))));
7502
7503             Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
7504
7505             --  Analyze the resulting list and suppress the generation of the
7506             --  Init_Proc associated with the above array declaration because
7507             --  this type is never used in object declarations. It is only used
7508             --  to simplify the expansion associated with dispatching calls.
7509
7510             Analyze_List (Result);
7511             Set_Suppress_Initialization (Base_Type (DT_Prims));
7512
7513             --  Disable backend optimizations based on assumptions about the
7514             --  aliasing status of objects designated by the access to the
7515             --  dispatch table. Required to handle dispatch tables imported
7516             --  from C++.
7517
7518             Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
7519
7520             --  Add the freezing nodes of these declarations; required to avoid
7521             --  generating these freezing nodes in wrong scopes (for example in
7522             --  the IC routine of a derivation of Typ).
7523             --  What is an "IC routine"? Is "init_proc" meant here???
7524
7525             Append_List_To (Result, Freeze_Entity (DT_Prims, Typ));
7526             Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ));
7527
7528             --  Mark entity of dispatch table. Required by the back end to
7529             --  handle them properly.
7530
7531             Set_Is_Dispatch_Table_Entity (DT_Prims);
7532          end;
7533       end if;
7534
7535       --  Mark entities of dispatch table. Required by the back end to handle
7536       --  them properly.
7537
7538       if Present (DT) then
7539          Set_Is_Dispatch_Table_Entity (DT);
7540          Set_Is_Dispatch_Table_Entity (Etype (DT));
7541       end if;
7542
7543       if Present (Iface_DT) then
7544          Set_Is_Dispatch_Table_Entity (Iface_DT);
7545          Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
7546       end if;
7547
7548       if Is_CPP_Class (Root_Type (Typ)) then
7549          Set_Ekind (DT_Ptr, E_Variable);
7550       else
7551          Set_Ekind (DT_Ptr, E_Constant);
7552       end if;
7553
7554       Set_Is_Tag       (DT_Ptr);
7555       Set_Related_Type (DT_Ptr, Typ);
7556
7557       return Result;
7558    end Make_Tags;
7559
7560    ---------------
7561    -- New_Value --
7562    ---------------
7563
7564    function New_Value (From : Node_Id) return Node_Id is
7565       Res : constant Node_Id := Duplicate_Subexpr (From);
7566    begin
7567       if Is_Access_Type (Etype (From)) then
7568          return
7569            Make_Explicit_Dereference (Sloc (From),
7570              Prefix => Res);
7571       else
7572          return Res;
7573       end if;
7574    end New_Value;
7575
7576    -----------------------------------
7577    -- Original_View_In_Visible_Part --
7578    -----------------------------------
7579
7580    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
7581       Scop : constant Entity_Id := Scope (Typ);
7582
7583    begin
7584       --  The scope must be a package
7585
7586       if not Is_Package_Or_Generic_Package (Scop) then
7587          return False;
7588       end if;
7589
7590       --  A type with a private declaration has a private view declared in
7591       --  the visible part.
7592
7593       if Has_Private_Declaration (Typ) then
7594          return True;
7595       end if;
7596
7597       return List_Containing (Parent (Typ)) =
7598         Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
7599    end Original_View_In_Visible_Part;
7600
7601    ------------------
7602    -- Prim_Op_Kind --
7603    ------------------
7604
7605    function Prim_Op_Kind
7606      (Prim : Entity_Id;
7607       Typ  : Entity_Id) return Node_Id
7608    is
7609       Full_Typ : Entity_Id := Typ;
7610       Loc      : constant Source_Ptr := Sloc (Prim);
7611       Prim_Op  : Entity_Id;
7612
7613    begin
7614       --  Retrieve the original primitive operation
7615
7616       Prim_Op := Ultimate_Alias (Prim);
7617
7618       if Ekind (Typ) = E_Record_Type
7619         and then Present (Corresponding_Concurrent_Type (Typ))
7620       then
7621          Full_Typ := Corresponding_Concurrent_Type (Typ);
7622       end if;
7623
7624       --  When a private tagged type is completed by a concurrent type,
7625       --  retrieve the full view.
7626
7627       if Is_Private_Type (Full_Typ) then
7628          Full_Typ := Full_View (Full_Typ);
7629       end if;
7630
7631       if Ekind (Prim_Op) = E_Function then
7632
7633          --  Protected function
7634
7635          if Ekind (Full_Typ) = E_Protected_Type then
7636             return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
7637
7638          --  Task function
7639
7640          elsif Ekind (Full_Typ) = E_Task_Type then
7641             return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
7642
7643          --  Regular function
7644
7645          else
7646             return New_Reference_To (RTE (RE_POK_Function), Loc);
7647          end if;
7648
7649       else
7650          pragma Assert (Ekind (Prim_Op) = E_Procedure);
7651
7652          if Ekind (Full_Typ) = E_Protected_Type then
7653
7654             --  Protected entry
7655
7656             if Is_Primitive_Wrapper (Prim_Op)
7657               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7658             then
7659                return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
7660
7661             --  Protected procedure
7662
7663             else
7664                return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
7665             end if;
7666
7667          elsif Ekind (Full_Typ) = E_Task_Type then
7668
7669             --  Task entry
7670
7671             if Is_Primitive_Wrapper (Prim_Op)
7672               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7673             then
7674                return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
7675
7676             --  Task "procedure". These are the internally Expander-generated
7677             --  procedures (task body for instance).
7678
7679             else
7680                return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
7681             end if;
7682
7683          --  Regular procedure
7684
7685          else
7686             return New_Reference_To (RTE (RE_POK_Procedure), Loc);
7687          end if;
7688       end if;
7689    end Prim_Op_Kind;
7690
7691    ------------------------
7692    -- Register_Primitive --
7693    ------------------------
7694
7695    function Register_Primitive
7696      (Loc     : Source_Ptr;
7697       Prim    : Entity_Id) return List_Id
7698    is
7699       DT_Ptr        : Entity_Id;
7700       Iface_Prim    : Entity_Id;
7701       Iface_Typ     : Entity_Id;
7702       Iface_DT_Ptr  : Entity_Id;
7703       Iface_DT_Elmt : Elmt_Id;
7704       L             : constant List_Id := New_List;
7705       Pos           : Uint;
7706       Tag           : Entity_Id;
7707       Tag_Typ       : Entity_Id;
7708       Thunk_Id      : Entity_Id;
7709       Thunk_Code    : Node_Id;
7710
7711    begin
7712       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
7713       pragma Assert (VM_Target = No_VM);
7714
7715       --  Do not register in the dispatch table eliminated primitives
7716
7717       if not RTE_Available (RE_Tag)
7718         or else Is_Eliminated (Ultimate_Alias (Prim))
7719       then
7720          return L;
7721       end if;
7722
7723       if not Present (Interface_Alias (Prim)) then
7724          Tag_Typ := Scope (DTC_Entity (Prim));
7725          Pos := DT_Position (Prim);
7726          Tag := First_Tag_Component (Tag_Typ);
7727
7728          if Is_Predefined_Dispatching_Operation (Prim)
7729            or else Is_Predefined_Dispatching_Alias (Prim)
7730          then
7731             DT_Ptr :=
7732               Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
7733
7734             Append_To (L,
7735               Build_Set_Predefined_Prim_Op_Address (Loc,
7736                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
7737                 Position     => Pos,
7738                 Address_Node =>
7739                   Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7740                     Make_Attribute_Reference (Loc,
7741                       Prefix         => New_Reference_To (Prim, Loc),
7742                       Attribute_Name => Name_Unrestricted_Access))));
7743
7744             --  Register copy of the pointer to the 'size primitive in the TSD
7745
7746             if Chars (Prim) = Name_uSize
7747               and then RTE_Record_Component_Available (RE_Size_Func)
7748             then
7749                DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7750                Append_To (L,
7751                  Build_Set_Size_Function (Loc,
7752                    Tag_Node  => New_Reference_To (DT_Ptr, Loc),
7753                    Size_Func => Prim));
7754             end if;
7755
7756          else
7757             pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
7758
7759             --  Skip registration of primitives located in the C++ part of the
7760             --  dispatch table. Their slot is set by the IC routine.
7761
7762             if not Is_CPP_Class (Root_Type (Tag_Typ))
7763               or else Pos > CPP_Num_Prims (Tag_Typ)
7764             then
7765                DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7766                Append_To (L,
7767                  Build_Set_Prim_Op_Address (Loc,
7768                    Typ          => Tag_Typ,
7769                    Tag_Node     => New_Reference_To (DT_Ptr, Loc),
7770                    Position     => Pos,
7771                    Address_Node =>
7772                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7773                        Make_Attribute_Reference (Loc,
7774                          Prefix         => New_Reference_To (Prim, Loc),
7775                          Attribute_Name => Name_Unrestricted_Access))));
7776             end if;
7777          end if;
7778
7779       --  Ada 2005 (AI-251): Primitive associated with an interface type
7780       --  Generate the code of the thunk only if the interface type is not an
7781       --  immediate ancestor of Typ; otherwise the dispatch table associated
7782       --  with the interface is the primary dispatch table and we have nothing
7783       --  else to do here.
7784
7785       else
7786          Tag_Typ   := Find_Dispatching_Type (Alias (Prim));
7787          Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
7788
7789          pragma Assert (Is_Interface (Iface_Typ));
7790
7791          --  No action needed for interfaces that are ancestors of Typ because
7792          --  their primitives are located in the primary dispatch table.
7793
7794          if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
7795             return L;
7796
7797          --  No action needed for primitives located in the C++ part of the
7798          --  dispatch table. Their slot is set by the IC routine.
7799
7800          elsif Is_CPP_Class (Root_Type (Tag_Typ))
7801             and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
7802             and then not Is_Predefined_Dispatching_Operation (Prim)
7803             and then not Is_Predefined_Dispatching_Alias (Prim)
7804          then
7805             return L;
7806          end if;
7807
7808          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
7809
7810          if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
7811            and then Present (Thunk_Code)
7812          then
7813             --  Generate the code necessary to fill the appropriate entry of
7814             --  the secondary dispatch table of Prim's controlling type with
7815             --  Thunk_Id's address.
7816
7817             Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
7818             Iface_DT_Ptr  := Node (Iface_DT_Elmt);
7819             pragma Assert (Has_Thunks (Iface_DT_Ptr));
7820
7821             Iface_Prim := Interface_Alias (Prim);
7822             Pos        := DT_Position (Iface_Prim);
7823             Tag        := First_Tag_Component (Iface_Typ);
7824
7825             Prepend_To (L, Thunk_Code);
7826
7827             if Is_Predefined_Dispatching_Operation (Prim)
7828               or else Is_Predefined_Dispatching_Alias (Prim)
7829             then
7830                Append_To (L,
7831                  Build_Set_Predefined_Prim_Op_Address (Loc,
7832                    Tag_Node =>
7833                      New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7834                    Position => Pos,
7835                    Address_Node =>
7836                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7837                        Make_Attribute_Reference (Loc,
7838                          Prefix          => New_Reference_To (Thunk_Id, Loc),
7839                          Attribute_Name  => Name_Unrestricted_Access))));
7840
7841                Next_Elmt (Iface_DT_Elmt);
7842                Next_Elmt (Iface_DT_Elmt);
7843                Iface_DT_Ptr := Node (Iface_DT_Elmt);
7844                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7845
7846                Append_To (L,
7847                  Build_Set_Predefined_Prim_Op_Address (Loc,
7848                    Tag_Node =>
7849                      New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7850                    Position => Pos,
7851                    Address_Node =>
7852                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7853                        Make_Attribute_Reference (Loc,
7854                          Prefix          =>
7855                            New_Reference_To (Alias (Prim), Loc),
7856                          Attribute_Name  => Name_Unrestricted_Access))));
7857
7858             else
7859                pragma Assert (Pos /= Uint_0
7860                  and then Pos <= DT_Entry_Count (Tag));
7861
7862                Append_To (L,
7863                  Build_Set_Prim_Op_Address (Loc,
7864                    Typ          => Iface_Typ,
7865                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
7866                    Position     => Pos,
7867                    Address_Node =>
7868                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7869                        Make_Attribute_Reference (Loc,
7870                          Prefix => New_Reference_To (Thunk_Id, Loc),
7871                          Attribute_Name => Name_Unrestricted_Access))));
7872
7873                Next_Elmt (Iface_DT_Elmt);
7874                Next_Elmt (Iface_DT_Elmt);
7875                Iface_DT_Ptr := Node (Iface_DT_Elmt);
7876                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7877
7878                Append_To (L,
7879                  Build_Set_Prim_Op_Address (Loc,
7880                    Typ          => Iface_Typ,
7881                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
7882                    Position     => Pos,
7883                    Address_Node =>
7884                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7885                        Make_Attribute_Reference (Loc,
7886                          Prefix         =>
7887                            New_Reference_To (Alias (Prim), Loc),
7888                          Attribute_Name => Name_Unrestricted_Access))));
7889
7890             end if;
7891          end if;
7892       end if;
7893
7894       return L;
7895    end Register_Primitive;
7896
7897    -------------------------
7898    -- Set_All_DT_Position --
7899    -------------------------
7900
7901    procedure Set_All_DT_Position (Typ : Entity_Id) is
7902
7903       function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
7904       --  Returns True if Prim is located in the dispatch table of
7905       --  predefined primitives
7906
7907       procedure Validate_Position (Prim : Entity_Id);
7908       --  Check that the position assigned to Prim is completely safe
7909       --  (it has not been assigned to a previously defined primitive
7910       --   operation of Typ)
7911
7912       ------------------------
7913       -- In_Predef_Prims_DT --
7914       ------------------------
7915
7916       function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
7917          E : Entity_Id;
7918
7919       begin
7920          --  Predefined primitives
7921
7922          if Is_Predefined_Dispatching_Operation (Prim) then
7923             return True;
7924
7925          --  Renamings of predefined primitives
7926
7927          elsif Present (Alias (Prim))
7928            and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
7929          then
7930             if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
7931                return True;
7932
7933             --  User-defined renamings of predefined equality have their own
7934             --  slot in the primary dispatch table
7935
7936             else
7937                E := Prim;
7938                while Present (Alias (E)) loop
7939                   if Comes_From_Source (E) then
7940                      return False;
7941                   end if;
7942
7943                   E := Alias (E);
7944                end loop;
7945
7946                return not Comes_From_Source (E);
7947             end if;
7948
7949          --  User-defined primitives
7950
7951          else
7952             return False;
7953          end if;
7954       end In_Predef_Prims_DT;
7955
7956       -----------------------
7957       -- Validate_Position --
7958       -----------------------
7959
7960       procedure Validate_Position (Prim : Entity_Id) is
7961          Op_Elmt : Elmt_Id;
7962          Op      : Entity_Id;
7963
7964       begin
7965          --  Aliased primitives are safe
7966
7967          if Present (Alias (Prim)) then
7968             return;
7969          end if;
7970
7971          Op_Elmt := First_Elmt (Primitive_Operations (Typ));
7972          while Present (Op_Elmt) loop
7973             Op := Node (Op_Elmt);
7974
7975             --  No need to check against itself
7976
7977             if Op = Prim then
7978                null;
7979
7980             --  Primitive operations covering abstract interfaces are
7981             --  allocated later
7982
7983             elsif Present (Interface_Alias (Op)) then
7984                null;
7985
7986             --  Predefined dispatching operations are completely safe. They
7987             --  are allocated at fixed positions in a separate table.
7988
7989             elsif Is_Predefined_Dispatching_Operation (Op)
7990                or else Is_Predefined_Dispatching_Alias (Op)
7991             then
7992                null;
7993
7994             --  Aliased subprograms are safe
7995
7996             elsif Present (Alias (Op)) then
7997                null;
7998
7999             elsif DT_Position (Op) = DT_Position (Prim)
8000                and then not Is_Predefined_Dispatching_Operation (Op)
8001                and then not Is_Predefined_Dispatching_Operation (Prim)
8002                and then not Is_Predefined_Dispatching_Alias (Op)
8003                and then not Is_Predefined_Dispatching_Alias (Prim)
8004             then
8005
8006                --  Handle aliased subprograms
8007
8008                declare
8009                   Op_1 : Entity_Id;
8010                   Op_2 : Entity_Id;
8011
8012                begin
8013                   Op_1 := Op;
8014                   loop
8015                      if Present (Overridden_Operation (Op_1)) then
8016                         Op_1 := Overridden_Operation (Op_1);
8017                      elsif Present (Alias (Op_1)) then
8018                         Op_1 := Alias (Op_1);
8019                      else
8020                         exit;
8021                      end if;
8022                   end loop;
8023
8024                   Op_2 := Prim;
8025                   loop
8026                      if Present (Overridden_Operation (Op_2)) then
8027                         Op_2 := Overridden_Operation (Op_2);
8028                      elsif Present (Alias (Op_2)) then
8029                         Op_2 := Alias (Op_2);
8030                      else
8031                         exit;
8032                      end if;
8033                   end loop;
8034
8035                   if Op_1 /= Op_2 then
8036                      raise Program_Error;
8037                   end if;
8038                end;
8039             end if;
8040
8041             Next_Elmt (Op_Elmt);
8042          end loop;
8043       end Validate_Position;
8044
8045       --  Local variables
8046
8047       Parent_Typ : constant Entity_Id := Etype (Typ);
8048       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
8049       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
8050
8051       Adjusted  : Boolean := False;
8052       Finalized : Boolean := False;
8053
8054       Count_Prim : Nat;
8055       DT_Length  : Nat;
8056       Nb_Prim    : Nat;
8057       Prim       : Entity_Id;
8058       Prim_Elmt  : Elmt_Id;
8059
8060    --  Start of processing for Set_All_DT_Position
8061
8062    begin
8063       pragma Assert (Present (First_Tag_Component (Typ)));
8064
8065       --  Set the DT_Position for each primitive operation. Perform some sanity
8066       --  checks to avoid building inconsistent dispatch tables.
8067
8068       --  First stage: Set the DTC entity of all the primitive operations. This
8069       --  is required to properly read the DT_Position attribute in the latter
8070       --  stages.
8071
8072       Prim_Elmt  := First_Prim;
8073       Count_Prim := 0;
8074       while Present (Prim_Elmt) loop
8075          Prim := Node (Prim_Elmt);
8076
8077          --  Predefined primitives have a separate dispatch table
8078
8079          if not In_Predef_Prims_DT (Prim) then
8080             Count_Prim := Count_Prim + 1;
8081          end if;
8082
8083          Set_DTC_Entity_Value (Typ, Prim);
8084
8085          --  Clear any previous value of the DT_Position attribute. In this
8086          --  way we ensure that the final position of all the primitives is
8087          --  established by the following stages of this algorithm.
8088
8089          Set_DT_Position (Prim, No_Uint);
8090
8091          Next_Elmt (Prim_Elmt);
8092       end loop;
8093
8094       declare
8095          Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
8096                         (others => False);
8097
8098          E : Entity_Id;
8099
8100          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
8101          --  Called if Typ is declared in a nested package or a public child
8102          --  package to handle inherited primitives that were inherited by Typ
8103          --  in the visible part, but whose declaration was deferred because
8104          --  the parent operation was private and not visible at that point.
8105
8106          procedure Set_Fixed_Prim (Pos : Nat);
8107          --  Sets to true an element of the Fixed_Prim table to indicate
8108          --  that this entry of the dispatch table of Typ is occupied.
8109
8110          ------------------------------------------
8111          -- Handle_Inherited_Private_Subprograms --
8112          ------------------------------------------
8113
8114          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
8115             Op_List     : Elist_Id;
8116             Op_Elmt     : Elmt_Id;
8117             Op_Elmt_2   : Elmt_Id;
8118             Prim_Op     : Entity_Id;
8119             Parent_Subp : Entity_Id;
8120
8121          begin
8122             Op_List := Primitive_Operations (Typ);
8123
8124             Op_Elmt := First_Elmt (Op_List);
8125             while Present (Op_Elmt) loop
8126                Prim_Op := Node (Op_Elmt);
8127
8128                --  Search primitives that are implicit operations with an
8129                --  internal name whose parent operation has a normal name.
8130
8131                if Present (Alias (Prim_Op))
8132                  and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
8133                  and then not Comes_From_Source (Prim_Op)
8134                  and then Is_Internal_Name (Chars (Prim_Op))
8135                  and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
8136                then
8137                   Parent_Subp := Alias (Prim_Op);
8138
8139                   --  Check if the type has an explicit overriding for this
8140                   --  primitive.
8141
8142                   Op_Elmt_2 := Next_Elmt (Op_Elmt);
8143                   while Present (Op_Elmt_2) loop
8144                      if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
8145                        and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
8146                      then
8147                         Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
8148                         Set_DT_Position (Node (Op_Elmt_2),
8149                           DT_Position (Parent_Subp));
8150                         Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
8151
8152                         goto Next_Primitive;
8153                      end if;
8154
8155                      Next_Elmt (Op_Elmt_2);
8156                   end loop;
8157                end if;
8158
8159                <<Next_Primitive>>
8160                Next_Elmt (Op_Elmt);
8161             end loop;
8162          end Handle_Inherited_Private_Subprograms;
8163
8164          --------------------
8165          -- Set_Fixed_Prim --
8166          --------------------
8167
8168          procedure Set_Fixed_Prim (Pos : Nat) is
8169          begin
8170             pragma Assert (Pos <= Count_Prim);
8171             Fixed_Prim (Pos) := True;
8172          exception
8173             when Constraint_Error =>
8174                raise Program_Error;
8175          end Set_Fixed_Prim;
8176
8177       begin
8178          --  In case of nested packages and public child package it may be
8179          --  necessary a special management on inherited subprograms so that
8180          --  the dispatch table is properly filled.
8181
8182          if Ekind (Scope (Scope (Typ))) = E_Package
8183            and then Scope (Scope (Typ)) /= Standard_Standard
8184            and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
8185                        or else
8186                         (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
8187                           and then Is_Generic_Type (Typ)))
8188            and then In_Open_Scopes (Scope (Etype (Typ)))
8189            and then Is_Base_Type (Typ)
8190          then
8191             Handle_Inherited_Private_Subprograms (Typ);
8192          end if;
8193
8194          --  Second stage: Register fixed entries
8195
8196          Nb_Prim   := 0;
8197          Prim_Elmt := First_Prim;
8198          while Present (Prim_Elmt) loop
8199             Prim := Node (Prim_Elmt);
8200
8201             --  Predefined primitives have a separate table and all its
8202             --  entries are at predefined fixed positions.
8203
8204             if In_Predef_Prims_DT (Prim) then
8205                if Is_Predefined_Dispatching_Operation (Prim) then
8206                   Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
8207
8208                else pragma Assert (Present (Alias (Prim)));
8209                   Set_DT_Position (Prim,
8210                     Default_Prim_Op_Position (Ultimate_Alias (Prim)));
8211                end if;
8212
8213             --  Overriding primitives of ancestor abstract interfaces
8214
8215             elsif Present (Interface_Alias (Prim))
8216               and then Is_Ancestor
8217                          (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
8218                           Use_Full_View => True)
8219             then
8220                pragma Assert (DT_Position (Prim) = No_Uint
8221                  and then Present (DTC_Entity (Interface_Alias (Prim))));
8222
8223                E := Interface_Alias (Prim);
8224                Set_DT_Position (Prim, DT_Position (E));
8225
8226                pragma Assert
8227                  (DT_Position (Alias (Prim)) = No_Uint
8228                     or else DT_Position (Alias (Prim)) = DT_Position (E));
8229                Set_DT_Position (Alias (Prim), DT_Position (E));
8230                Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
8231
8232             --  Overriding primitives must use the same entry as the
8233             --  overridden primitive.
8234
8235             elsif not Present (Interface_Alias (Prim))
8236               and then Present (Alias (Prim))
8237               and then Chars (Prim) = Chars (Alias (Prim))
8238               and then Find_Dispatching_Type (Alias (Prim)) /= Typ
8239               and then Is_Ancestor
8240                          (Find_Dispatching_Type (Alias (Prim)), Typ,
8241                           Use_Full_View => True)
8242               and then Present (DTC_Entity (Alias (Prim)))
8243             then
8244                E := Alias (Prim);
8245                Set_DT_Position (Prim, DT_Position (E));
8246
8247                if not Is_Predefined_Dispatching_Alias (E) then
8248                   Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
8249                end if;
8250             end if;
8251
8252             Next_Elmt (Prim_Elmt);
8253          end loop;
8254
8255          --  Third stage: Fix the position of all the new primitives.
8256          --  Entries associated with primitives covering interfaces
8257          --  are handled in a latter round.
8258
8259          Prim_Elmt := First_Prim;
8260          while Present (Prim_Elmt) loop
8261             Prim := Node (Prim_Elmt);
8262
8263             --  Skip primitives previously set entries
8264
8265             if DT_Position (Prim) /= No_Uint then
8266                null;
8267
8268             --  Primitives covering interface primitives are handled later
8269
8270             elsif Present (Interface_Alias (Prim)) then
8271                null;
8272
8273             else
8274                --  Take the next available position in the DT
8275
8276                loop
8277                   Nb_Prim := Nb_Prim + 1;
8278                   pragma Assert (Nb_Prim <= Count_Prim);
8279                   exit when not Fixed_Prim (Nb_Prim);
8280                end loop;
8281
8282                Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
8283                Set_Fixed_Prim (Nb_Prim);
8284             end if;
8285
8286             Next_Elmt (Prim_Elmt);
8287          end loop;
8288       end;
8289
8290       --  Fourth stage: Complete the decoration of primitives covering
8291       --  interfaces (that is, propagate the DT_Position attribute
8292       --  from the aliased primitive)
8293
8294       Prim_Elmt := First_Prim;
8295       while Present (Prim_Elmt) loop
8296          Prim := Node (Prim_Elmt);
8297
8298          if DT_Position (Prim) = No_Uint
8299            and then Present (Interface_Alias (Prim))
8300          then
8301             pragma Assert (Present (Alias (Prim))
8302               and then Find_Dispatching_Type (Alias (Prim)) = Typ);
8303
8304             --  Check if this entry will be placed in the primary DT
8305
8306             if Is_Ancestor
8307                  (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
8308                   Use_Full_View => True)
8309             then
8310                pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
8311                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
8312
8313             --  Otherwise it will be placed in the secondary DT
8314
8315             else
8316                pragma Assert
8317                  (DT_Position (Interface_Alias (Prim)) /= No_Uint);
8318                Set_DT_Position (Prim,
8319                  DT_Position (Interface_Alias (Prim)));
8320             end if;
8321          end if;
8322
8323          Next_Elmt (Prim_Elmt);
8324       end loop;
8325
8326       --  Generate listing showing the contents of the dispatch tables.
8327       --  This action is done before some further static checks because
8328       --  in case of critical errors caused by a wrong dispatch table
8329       --  we need to see the contents of such table.
8330
8331       if Debug_Flag_ZZ then
8332          Write_DT (Typ);
8333       end if;
8334
8335       --  Final stage: Ensure that the table is correct plus some further
8336       --  verifications concerning the primitives.
8337
8338       Prim_Elmt := First_Prim;
8339       DT_Length := 0;
8340       while Present (Prim_Elmt) loop
8341          Prim := Node (Prim_Elmt);
8342
8343          --  At this point all the primitives MUST have a position
8344          --  in the dispatch table.
8345
8346          if DT_Position (Prim) = No_Uint then
8347             raise Program_Error;
8348          end if;
8349
8350          --  Calculate real size of the dispatch table
8351
8352          if not In_Predef_Prims_DT (Prim)
8353            and then UI_To_Int (DT_Position (Prim)) > DT_Length
8354          then
8355             DT_Length := UI_To_Int (DT_Position (Prim));
8356          end if;
8357
8358          --  Ensure that the assigned position to non-predefined
8359          --  dispatching operations in the dispatch table is correct.
8360
8361          if not Is_Predefined_Dispatching_Operation (Prim)
8362            and then not Is_Predefined_Dispatching_Alias (Prim)
8363          then
8364             Validate_Position (Prim);
8365          end if;
8366
8367          if Chars (Prim) = Name_Finalize then
8368             Finalized := True;
8369          end if;
8370
8371          if Chars (Prim) = Name_Adjust then
8372             Adjusted := True;
8373          end if;
8374
8375          --  An abstract operation cannot be declared in the private part for a
8376          --  visible abstract type, because it can't be overridden outside this
8377          --  package hierarchy. For explicit declarations this is checked at
8378          --  the point of declaration, but for inherited operations it must be
8379          --  done when building the dispatch table.
8380
8381          --  Ada 2005 (AI-251): Primitives associated with interfaces are
8382          --  excluded from this check because interfaces must be visible in
8383          --  the public and private part (RM 7.3 (7.3/2))
8384
8385          --  We disable this check in CodePeer mode, to accommodate legacy
8386          --  Ada code.
8387
8388          if not CodePeer_Mode
8389            and then Is_Abstract_Type (Typ)
8390            and then Is_Abstract_Subprogram (Prim)
8391            and then Present (Alias (Prim))
8392            and then not Is_Interface
8393                           (Find_Dispatching_Type (Ultimate_Alias (Prim)))
8394            and then not Present (Interface_Alias (Prim))
8395            and then Is_Derived_Type (Typ)
8396            and then In_Private_Part (Current_Scope)
8397            and then
8398              List_Containing (Parent (Prim)) =
8399                Private_Declarations
8400                 (Specification (Unit_Declaration_Node (Current_Scope)))
8401            and then Original_View_In_Visible_Part (Typ)
8402          then
8403             --  We exclude Input and Output stream operations because
8404             --  Limited_Controlled inherits useless Input and Output
8405             --  stream operations from Root_Controlled, which can
8406             --  never be overridden.
8407
8408             if not Is_TSS (Prim, TSS_Stream_Input)
8409                  and then
8410                not Is_TSS (Prim, TSS_Stream_Output)
8411             then
8412                Error_Msg_NE
8413                  ("abstract inherited private operation&" &
8414                   " must be overridden (RM 3.9.3(10))",
8415                  Parent (Typ), Prim);
8416             end if;
8417          end if;
8418
8419          Next_Elmt (Prim_Elmt);
8420       end loop;
8421
8422       --  Additional check
8423
8424       if Is_Controlled (Typ) then
8425          if not Finalized then
8426             Error_Msg_N
8427               ("controlled type has no explicit Finalize method??", Typ);
8428
8429          elsif not Adjusted then
8430             Error_Msg_N
8431               ("controlled type has no explicit Adjust method??", Typ);
8432          end if;
8433       end if;
8434
8435       --  Set the final size of the Dispatch Table
8436
8437       Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
8438
8439       --  The derived type must have at least as many components as its parent
8440       --  (for root types Etype points to itself and the test cannot fail).
8441
8442       if DT_Entry_Count (The_Tag) <
8443            DT_Entry_Count (First_Tag_Component (Parent_Typ))
8444       then
8445          raise Program_Error;
8446       end if;
8447    end Set_All_DT_Position;
8448
8449    --------------------------
8450    -- Set_CPP_Constructors --
8451    --------------------------
8452
8453    procedure Set_CPP_Constructors (Typ : Entity_Id) is
8454
8455       function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
8456       --  Duplicate the parameters profile of the imported C++ constructor
8457       --  adding an access to the object as an additional parameter.
8458
8459       function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
8460          Loc   : constant Source_Ptr := Sloc (E);
8461          Parms : List_Id;
8462          P     : Node_Id;
8463
8464       begin
8465          Parms :=
8466            New_List (
8467              Make_Parameter_Specification (Loc,
8468                Defining_Identifier =>
8469                  Make_Defining_Identifier (Loc, Name_uInit),
8470                Parameter_Type      => New_Reference_To (Typ, Loc)));
8471
8472          if Present (Parameter_Specifications (Parent (E))) then
8473             P := First (Parameter_Specifications (Parent (E)));
8474             while Present (P) loop
8475                Append_To (Parms,
8476                  Make_Parameter_Specification (Loc,
8477                    Defining_Identifier =>
8478                      Make_Defining_Identifier (Loc,
8479                        Chars => Chars (Defining_Identifier (P))),
8480                    Parameter_Type      => New_Copy_Tree (Parameter_Type (P)),
8481                    Expression          => New_Copy_Tree (Expression (P))));
8482                Next (P);
8483             end loop;
8484          end if;
8485
8486          return Parms;
8487       end Gen_Parameters_Profile;
8488
8489       --  Local variables
8490
8491       Loc     : Source_Ptr;
8492       E       : Entity_Id;
8493       Found   : Boolean := False;
8494       IP      : Entity_Id;
8495       IP_Body : Node_Id;
8496       P       : Node_Id;
8497       Parms   : List_Id;
8498
8499       Covers_Default_Constructor : Entity_Id := Empty;
8500
8501    --  Start of processing for Set_CPP_Constructor
8502
8503    begin
8504       pragma Assert (Is_CPP_Class (Typ));
8505
8506       --  Look for the constructor entities
8507
8508       E := Next_Entity (Typ);
8509       while Present (E) loop
8510          if Ekind (E) = E_Function
8511            and then Is_Constructor (E)
8512          then
8513             Found := True;
8514             Loc   := Sloc (E);
8515             Parms := Gen_Parameters_Profile (E);
8516             IP    :=
8517               Make_Defining_Identifier (Loc,
8518                 Chars => Make_Init_Proc_Name (Typ));
8519
8520             --  Case 1: Constructor of non-tagged type
8521
8522             --  If the C++ class has no virtual methods then the matching Ada
8523             --  type is a non-tagged record type. In such case there is no need
8524             --  to generate a wrapper of the C++ constructor because the _tag
8525             --  component is not available.
8526
8527             if not Is_Tagged_Type (Typ) then
8528                Discard_Node
8529                  (Make_Subprogram_Declaration (Loc,
8530                     Specification =>
8531                       Make_Procedure_Specification (Loc,
8532                         Defining_Unit_Name       => IP,
8533                         Parameter_Specifications => Parms)));
8534
8535                Set_Init_Proc (Typ, IP);
8536                Set_Is_Imported    (IP);
8537                Set_Is_Constructor (IP);
8538                Set_Interface_Name (IP, Interface_Name (E));
8539                Set_Convention     (IP, Convention_CPP);
8540                Set_Is_Public      (IP);
8541                Set_Has_Completion (IP);
8542
8543             --  Case 2: Constructor of a tagged type
8544
8545             --  In this case we generate the IP as a wrapper of the the
8546             --  C++ constructor because IP must also save copy of the _tag
8547             --  generated in the C++ side. The copy of the _tag is used by
8548             --  Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8549
8550             --  Generate:
8551             --     procedure IP (_init : Typ; ...) is
8552             --        procedure ConstructorP (_init : Typ; ...);
8553             --        pragma Import (ConstructorP);
8554             --     begin
8555             --        ConstructorP (_init, ...);
8556             --        if Typ._tag = null then
8557             --           Typ._tag := _init._tag;
8558             --        end if;
8559             --     end IP;
8560
8561             else
8562                declare
8563                   Body_Stmts            : constant List_Id := New_List;
8564                   Constructor_Id        : Entity_Id;
8565                   Constructor_Decl_Node : Node_Id;
8566                   Init_Tags_List        : List_Id;
8567
8568                begin
8569                   Constructor_Id := Make_Temporary (Loc, 'P');
8570
8571                   Constructor_Decl_Node :=
8572                     Make_Subprogram_Declaration (Loc,
8573                       Make_Procedure_Specification (Loc,
8574                         Defining_Unit_Name => Constructor_Id,
8575                         Parameter_Specifications => Parms));
8576
8577                   Set_Is_Imported    (Constructor_Id);
8578                   Set_Is_Constructor (Constructor_Id);
8579                   Set_Interface_Name (Constructor_Id, Interface_Name (E));
8580                   Set_Convention     (Constructor_Id, Convention_CPP);
8581                   Set_Is_Public      (Constructor_Id);
8582                   Set_Has_Completion (Constructor_Id);
8583
8584                   --  Build the init procedure as a wrapper of this constructor
8585
8586                   Parms := Gen_Parameters_Profile (E);
8587
8588                   --  Invoke the C++ constructor
8589
8590                   declare
8591                      Actuals : constant List_Id := New_List;
8592
8593                   begin
8594                      P := First (Parms);
8595                      while Present (P) loop
8596                         Append_To (Actuals,
8597                           New_Reference_To (Defining_Identifier (P), Loc));
8598                         Next (P);
8599                      end loop;
8600
8601                      Append_To (Body_Stmts,
8602                        Make_Procedure_Call_Statement (Loc,
8603                          Name => New_Reference_To (Constructor_Id, Loc),
8604                          Parameter_Associations => Actuals));
8605                   end;
8606
8607                   --  Initialize copies of C++ primary and secondary tags
8608
8609                   Init_Tags_List := New_List;
8610
8611                   declare
8612                      Tag_Elmt : Elmt_Id;
8613                      Tag_Comp : Node_Id;
8614
8615                   begin
8616                      Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
8617                      Tag_Comp := First_Tag_Component (Typ);
8618
8619                      while Present (Tag_Elmt)
8620                        and then Is_Tag (Node (Tag_Elmt))
8621                      loop
8622                         --  Skip the following assertion with primary tags
8623                         --  because Related_Type is not set on primary tag
8624                         --  components
8625
8626                         pragma Assert
8627                           (Tag_Comp = First_Tag_Component (Typ)
8628                              or else Related_Type (Node (Tag_Elmt))
8629                                        = Related_Type (Tag_Comp));
8630
8631                         Append_To (Init_Tags_List,
8632                           Make_Assignment_Statement (Loc,
8633                             Name =>
8634                               New_Reference_To (Node (Tag_Elmt), Loc),
8635                             Expression =>
8636                               Make_Selected_Component (Loc,
8637                                 Prefix        =>
8638                                   Make_Identifier (Loc, Name_uInit),
8639                                 Selector_Name =>
8640                                   New_Reference_To (Tag_Comp, Loc))));
8641
8642                         Tag_Comp := Next_Tag_Component (Tag_Comp);
8643                         Next_Elmt (Tag_Elmt);
8644                      end loop;
8645                   end;
8646
8647                   Append_To (Body_Stmts,
8648                     Make_If_Statement (Loc,
8649                       Condition =>
8650                         Make_Op_Eq (Loc,
8651                           Left_Opnd =>
8652                             New_Reference_To
8653                               (Node (First_Elmt (Access_Disp_Table (Typ))),
8654                                Loc),
8655                           Right_Opnd =>
8656                             Unchecked_Convert_To (RTE (RE_Tag),
8657                               New_Reference_To (RTE (RE_Null_Address), Loc))),
8658                       Then_Statements => Init_Tags_List));
8659
8660                   IP_Body :=
8661                     Make_Subprogram_Body (Loc,
8662                       Specification =>
8663                         Make_Procedure_Specification (Loc,
8664                           Defining_Unit_Name => IP,
8665                           Parameter_Specifications => Parms),
8666                       Declarations => New_List (Constructor_Decl_Node),
8667                       Handled_Statement_Sequence =>
8668                         Make_Handled_Sequence_Of_Statements (Loc,
8669                           Statements => Body_Stmts,
8670                           Exception_Handlers => No_List));
8671
8672                   Discard_Node (IP_Body);
8673                   Set_Init_Proc (Typ, IP);
8674                end;
8675             end if;
8676
8677             --  If this constructor has parameters and all its parameters
8678             --  have defaults then it covers the default constructor. The
8679             --  semantic analyzer ensures that only one constructor with
8680             --  defaults covers the default constructor.
8681
8682             if Present (Parameter_Specifications (Parent (E)))
8683               and then Needs_No_Actuals (E)
8684             then
8685                Covers_Default_Constructor := IP;
8686             end if;
8687          end if;
8688
8689          Next_Entity (E);
8690       end loop;
8691
8692       --  If there are no constructors, mark the type as abstract since we
8693       --  won't be able to declare objects of that type.
8694
8695       if not Found then
8696          Set_Is_Abstract_Type (Typ);
8697       end if;
8698
8699       --  Handle constructor that has all its parameters with defaults and
8700       --  hence it covers the default constructor. We generate a wrapper IP
8701       --  which calls the covering constructor.
8702
8703       if Present (Covers_Default_Constructor) then
8704          declare
8705             Body_Stmts : List_Id;
8706
8707          begin
8708             Loc := Sloc (Covers_Default_Constructor);
8709
8710             Body_Stmts := New_List (
8711               Make_Procedure_Call_Statement (Loc,
8712                 Name                   =>
8713                   New_Reference_To (Covers_Default_Constructor, Loc),
8714                 Parameter_Associations => New_List (
8715                   Make_Identifier (Loc, Name_uInit))));
8716
8717             IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
8718
8719             IP_Body :=
8720               Make_Subprogram_Body (Loc,
8721                 Specification              =>
8722                   Make_Procedure_Specification (Loc,
8723                     Defining_Unit_Name       => IP,
8724                     Parameter_Specifications => New_List (
8725                       Make_Parameter_Specification (Loc,
8726                         Defining_Identifier =>
8727                           Make_Defining_Identifier (Loc, Name_uInit),
8728                         Parameter_Type      => New_Reference_To (Typ, Loc)))),
8729
8730                 Declarations               => No_List,
8731
8732                 Handled_Statement_Sequence =>
8733                   Make_Handled_Sequence_Of_Statements (Loc,
8734                     Statements         => Body_Stmts,
8735                     Exception_Handlers => No_List));
8736
8737             Discard_Node (IP_Body);
8738             Set_Init_Proc (Typ, IP);
8739          end;
8740       end if;
8741
8742       --  If the CPP type has constructors then it must import also the default
8743       --  C++ constructor. It is required for default initialization of objects
8744       --  of the type. It is also required to elaborate objects of Ada types
8745       --  that are defined as derivations of this CPP type.
8746
8747       if Has_CPP_Constructors (Typ)
8748         and then No (Init_Proc (Typ))
8749       then
8750          Error_Msg_N ("??default constructor must be imported from C++", Typ);
8751       end if;
8752    end Set_CPP_Constructors;
8753
8754    --------------------------
8755    -- Set_DTC_Entity_Value --
8756    --------------------------
8757
8758    procedure Set_DTC_Entity_Value
8759      (Tagged_Type : Entity_Id;
8760       Prim        : Entity_Id)
8761    is
8762    begin
8763       if Present (Interface_Alias (Prim))
8764         and then Is_Interface
8765                    (Find_Dispatching_Type (Interface_Alias (Prim)))
8766       then
8767          Set_DTC_Entity (Prim,
8768            Find_Interface_Tag
8769              (T     => Tagged_Type,
8770               Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
8771       else
8772          Set_DTC_Entity (Prim,
8773            First_Tag_Component (Tagged_Type));
8774       end if;
8775    end Set_DTC_Entity_Value;
8776
8777    -----------------
8778    -- Tagged_Kind --
8779    -----------------
8780
8781    function Tagged_Kind (T : Entity_Id) return Node_Id is
8782       Conc_Typ : Entity_Id;
8783       Loc      : constant Source_Ptr := Sloc (T);
8784
8785    begin
8786       pragma Assert
8787         (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
8788
8789       --  Abstract kinds
8790
8791       if Is_Abstract_Type (T) then
8792          if Is_Limited_Record (T) then
8793             return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
8794          else
8795             return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
8796          end if;
8797
8798       --  Concurrent kinds
8799
8800       elsif Is_Concurrent_Record_Type (T) then
8801          Conc_Typ := Corresponding_Concurrent_Type (T);
8802
8803          if Present (Full_View (Conc_Typ)) then
8804             Conc_Typ := Full_View (Conc_Typ);
8805          end if;
8806
8807          if Ekind (Conc_Typ) = E_Protected_Type then
8808             return New_Reference_To (RTE (RE_TK_Protected), Loc);
8809          else
8810             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
8811             return New_Reference_To (RTE (RE_TK_Task), Loc);
8812          end if;
8813
8814       --  Regular tagged kinds
8815
8816       else
8817          if Is_Limited_Record (T) then
8818             return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
8819          else
8820             return New_Reference_To (RTE (RE_TK_Tagged), Loc);
8821          end if;
8822       end if;
8823    end Tagged_Kind;
8824
8825    --------------
8826    -- Write_DT --
8827    --------------
8828
8829    procedure Write_DT (Typ : Entity_Id) is
8830       Elmt : Elmt_Id;
8831       Prim : Node_Id;
8832
8833    begin
8834       --  Protect this procedure against wrong usage. Required because it will
8835       --  be used directly from GDB
8836
8837       if not (Typ <= Last_Node_Id)
8838         or else not Is_Tagged_Type (Typ)
8839       then
8840          Write_Str ("wrong usage: Write_DT must be used with tagged types");
8841          Write_Eol;
8842          return;
8843       end if;
8844
8845       Write_Int (Int (Typ));
8846       Write_Str (": ");
8847       Write_Name (Chars (Typ));
8848
8849       if Is_Interface (Typ) then
8850          Write_Str (" is interface");
8851       end if;
8852
8853       Write_Eol;
8854
8855       Elmt := First_Elmt (Primitive_Operations (Typ));
8856       while Present (Elmt) loop
8857          Prim := Node (Elmt);
8858          Write_Str  (" - ");
8859
8860          --  Indicate if this primitive will be allocated in the primary
8861          --  dispatch table or in a secondary dispatch table associated
8862          --  with an abstract interface type
8863
8864          if Present (DTC_Entity (Prim)) then
8865             if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
8866                Write_Str ("[P] ");
8867             else
8868                Write_Str ("[s] ");
8869             end if;
8870          end if;
8871
8872          --  Output the node of this primitive operation and its name
8873
8874          Write_Int  (Int (Prim));
8875          Write_Str  (": ");
8876
8877          if Is_Predefined_Dispatching_Operation (Prim) then
8878             Write_Str ("(predefined) ");
8879          end if;
8880
8881          --  Prefix the name of the primitive with its corresponding tagged
8882          --  type to facilitate seeing inherited primitives.
8883
8884          if Present (Alias (Prim)) then
8885             Write_Name
8886               (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
8887          else
8888             Write_Name (Chars (Typ));
8889          end if;
8890
8891          Write_Str (".");
8892          Write_Name (Chars (Prim));
8893
8894          --  Indicate if this primitive has an aliased primitive
8895
8896          if Present (Alias (Prim)) then
8897             Write_Str (" (alias = ");
8898             Write_Int (Int (Alias (Prim)));
8899
8900             --  If the DTC_Entity attribute is already set we can also output
8901             --  the name of the interface covered by this primitive (if any).
8902
8903             if Ekind_In (Alias (Prim), E_Function, E_Procedure)
8904               and then Present (DTC_Entity (Alias (Prim)))
8905               and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
8906             then
8907                Write_Str  (" from interface ");
8908                Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
8909             end if;
8910
8911             if Present (Interface_Alias (Prim)) then
8912                Write_Str  (", AI_Alias of ");
8913
8914                if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
8915                   Write_Str ("null primitive ");
8916                end if;
8917
8918                Write_Name
8919                  (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
8920                Write_Char (':');
8921                Write_Int  (Int (Interface_Alias (Prim)));
8922             end if;
8923
8924             Write_Str (")");
8925          end if;
8926
8927          --  Display the final position of this primitive in its associated
8928          --  (primary or secondary) dispatch table
8929
8930          if Present (DTC_Entity (Prim))
8931            and then DT_Position (Prim) /= No_Uint
8932          then
8933             Write_Str (" at #");
8934             Write_Int (UI_To_Int (DT_Position (Prim)));
8935          end if;
8936
8937          if Is_Abstract_Subprogram (Prim) then
8938             Write_Str (" is abstract;");
8939
8940          --  Check if this is a null primitive
8941
8942          elsif Comes_From_Source (Prim)
8943            and then Ekind (Prim) = E_Procedure
8944            and then Null_Present (Parent (Prim))
8945          then
8946             Write_Str (" is null;");
8947          end if;
8948
8949          if Is_Eliminated (Ultimate_Alias (Prim)) then
8950             Write_Str (" (eliminated)");
8951          end if;
8952
8953          if Is_Imported (Prim)
8954            and then Convention (Prim) = Convention_CPP
8955          then
8956             Write_Str (" (C++)");
8957          end if;
8958
8959          Write_Eol;
8960
8961          Next_Elmt (Elmt);
8962       end loop;
8963    end Write_DT;
8964
8965 end Exp_Disp;