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