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