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 (Node (Elmt));
3917          Set_Interface_Name (DT,
3918            Make_String_Literal (Loc,
3919              Strval => String_From_Name_Buffer));
3920
3921          --  Ensure proper Sprint output of this implicit importation
3922
3923          Set_Is_Internal (DT);
3924          Set_Is_Public (DT);
3925       end Export_DT;
3926
3927       -----------------------
3928       -- Make_Secondary_DT --
3929       -----------------------
3930
3931       procedure Make_Secondary_DT
3932         (Typ              : Entity_Id;
3933          Iface            : Entity_Id;
3934          Suffix_Index     : Int;
3935          Num_Iface_Prims  : Nat;
3936          Iface_DT_Ptr     : Entity_Id;
3937          Predef_Prims_Ptr : Entity_Id;
3938          Build_Thunks     : Boolean;
3939          Result           : List_Id)
3940       is
3941          Loc                : constant Source_Ptr := Sloc (Typ);
3942          Exporting_Table    : constant Boolean :=
3943                                 Building_Static_DT (Typ)
3944                                   and then Suffix_Index > 0;
3945          Iface_DT           : constant Entity_Id := Make_Temporary (Loc, 'T');
3946          Predef_Prims       : constant Entity_Id := Make_Temporary (Loc, 'R');
3947          DT_Constr_List     : List_Id;
3948          DT_Aggr_List       : List_Id;
3949          Empty_DT           : Boolean := False;
3950          Nb_Predef_Prims    : Nat := 0;
3951          Nb_Prim            : Nat;
3952          New_Node           : Node_Id;
3953          OSD                : Entity_Id;
3954          OSD_Aggr_List      : List_Id;
3955          Pos                : Nat;
3956          Prim               : Entity_Id;
3957          Prim_Elmt          : Elmt_Id;
3958          Prim_Ops_Aggr_List : List_Id;
3959
3960       begin
3961          --  Handle cases in which we do not generate statically allocated
3962          --  dispatch tables.
3963
3964          if not Building_Static_DT (Typ) then
3965             Set_Ekind (Predef_Prims, E_Variable);
3966             Set_Ekind (Iface_DT, E_Variable);
3967
3968          --  Statically allocated dispatch tables and related entities are
3969          --  constants.
3970
3971          else
3972             Set_Ekind (Predef_Prims, E_Constant);
3973             Set_Is_Statically_Allocated (Predef_Prims);
3974             Set_Is_True_Constant (Predef_Prims);
3975
3976             Set_Ekind (Iface_DT, E_Constant);
3977             Set_Is_Statically_Allocated (Iface_DT);
3978             Set_Is_True_Constant (Iface_DT);
3979          end if;
3980
3981          --  Calculate the number of slots of the dispatch table. If the number
3982          --  of primitives of Typ is 0 we reserve a dummy single entry for its
3983          --  DT because at run time the pointer to this dummy entry will be
3984          --  used as the tag.
3985
3986          if Num_Iface_Prims = 0 then
3987             Empty_DT := True;
3988             Nb_Prim  := 1;
3989          else
3990             Nb_Prim  := Num_Iface_Prims;
3991          end if;
3992
3993          --  Generate:
3994
3995          --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3996          --                    (predef-prim-op-thunk-1'address,
3997          --                     predef-prim-op-thunk-2'address,
3998          --                     ...
3999          --                     predef-prim-op-thunk-n'address);
4000          --   for Predef_Prims'Alignment use Address'Alignment
4001
4002          --  Stage 1: Calculate the number of predefined primitives
4003
4004          if not Building_Static_DT (Typ) then
4005             Nb_Predef_Prims := Max_Predef_Prims;
4006          else
4007             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4008             while Present (Prim_Elmt) loop
4009                Prim := Node (Prim_Elmt);
4010
4011                if Is_Predefined_Dispatching_Operation (Prim)
4012                  and then not Is_Abstract_Subprogram (Prim)
4013                then
4014                   Pos := UI_To_Int (DT_Position (Prim));
4015
4016                   if Pos > Nb_Predef_Prims then
4017                      Nb_Predef_Prims := Pos;
4018                   end if;
4019                end if;
4020
4021                Next_Elmt (Prim_Elmt);
4022             end loop;
4023          end if;
4024
4025          --  Stage 2: Create the thunks associated with the predefined
4026          --  primitives and save their entity to fill the aggregate.
4027
4028          declare
4029             Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
4030             Decl       : Node_Id;
4031             Thunk_Id   : Entity_Id;
4032             Thunk_Code : Node_Id;
4033
4034          begin
4035             Prim_Ops_Aggr_List := New_List;
4036             Prim_Table := (others => Empty);
4037
4038             if Building_Static_DT (Typ) then
4039                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4040                while Present (Prim_Elmt) loop
4041                   Prim := Node (Prim_Elmt);
4042
4043                   if Is_Predefined_Dispatching_Operation (Prim)
4044                     and then not Is_Abstract_Subprogram (Prim)
4045                     and then not Is_Eliminated (Prim)
4046                     and then not Present (Prim_Table
4047                                            (UI_To_Int (DT_Position (Prim))))
4048                   then
4049                      if not Build_Thunks then
4050                         Prim_Table (UI_To_Int (DT_Position (Prim))) :=
4051                           Alias (Prim);
4052
4053                      else
4054                         Expand_Interface_Thunk
4055                           (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
4056
4057                         if Present (Thunk_Id) then
4058                            Append_To (Result, Thunk_Code);
4059                            Prim_Table (UI_To_Int (DT_Position (Prim)))
4060                              := Thunk_Id;
4061                         end if;
4062                      end if;
4063                   end if;
4064
4065                   Next_Elmt (Prim_Elmt);
4066                end loop;
4067             end if;
4068
4069             for J in Prim_Table'Range loop
4070                if Present (Prim_Table (J)) then
4071                   New_Node :=
4072                     Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4073                       Make_Attribute_Reference (Loc,
4074                         Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
4075                         Attribute_Name => Name_Unrestricted_Access));
4076                else
4077                   New_Node := Make_Null (Loc);
4078                end if;
4079
4080                Append_To (Prim_Ops_Aggr_List, New_Node);
4081             end loop;
4082
4083             New_Node :=
4084               Make_Aggregate (Loc,
4085                 Expressions => Prim_Ops_Aggr_List);
4086
4087             --  Remember aggregates initializing dispatch tables
4088
4089             Append_Elmt (New_Node, DT_Aggr);
4090
4091             Decl :=
4092               Make_Subtype_Declaration (Loc,
4093                 Defining_Identifier => Make_Temporary (Loc, 'S'),
4094                 Subtype_Indication  =>
4095                   New_Occurrence_Of (RTE (RE_Address_Array), Loc));
4096
4097             Append_To (Result, Decl);
4098
4099             Append_To (Result,
4100               Make_Object_Declaration (Loc,
4101                 Defining_Identifier => Predef_Prims,
4102                 Constant_Present    => Building_Static_DT (Typ),
4103                 Aliased_Present     => True,
4104                 Object_Definition   => New_Occurrence_Of
4105                                          (Defining_Identifier (Decl), Loc),
4106                 Expression => New_Node));
4107
4108             Append_To (Result,
4109               Make_Attribute_Definition_Clause (Loc,
4110                 Name       => New_Occurrence_Of (Predef_Prims, Loc),
4111                 Chars      => Name_Alignment,
4112                 Expression =>
4113                   Make_Attribute_Reference (Loc,
4114                     Prefix =>
4115                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4116                     Attribute_Name => Name_Alignment)));
4117          end;
4118
4119          --  Generate
4120
4121          --   OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
4122          --          (OSD_Table => (1 => <value>,
4123          --                           ...
4124          --                         N => <value>));
4125
4126          --   Iface_DT : Dispatch_Table (Nb_Prims) :=
4127          --               ([ Signature   => <sig-value> ],
4128          --                Tag_Kind      => <tag_kind-value>,
4129          --                Predef_Prims  => Predef_Prims'Address,
4130          --                Offset_To_Top => 0,
4131          --                OSD           => OSD'Address,
4132          --                Prims_Ptr     => (prim-op-1'address,
4133          --                                  prim-op-2'address,
4134          --                                  ...
4135          --                                  prim-op-n'address));
4136          --   for Iface_DT'Alignment use Address'Alignment;
4137
4138          --  Stage 3: Initialize the discriminant and the record components
4139
4140          DT_Constr_List := New_List;
4141          DT_Aggr_List   := New_List;
4142
4143          --  Nb_Prim
4144
4145          Append_To (DT_Constr_List, Make_Integer_Literal (Loc, Nb_Prim));
4146          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, Nb_Prim));
4147
4148          --  Signature
4149
4150          if RTE_Record_Component_Available (RE_Signature) then
4151             Append_To (DT_Aggr_List,
4152               New_Occurrence_Of (RTE (RE_Secondary_DT), Loc));
4153          end if;
4154
4155          --  Tag_Kind
4156
4157          if RTE_Record_Component_Available (RE_Tag_Kind) then
4158             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
4159          end if;
4160
4161          --  Predef_Prims
4162
4163          Append_To (DT_Aggr_List,
4164            Make_Attribute_Reference (Loc,
4165              Prefix => New_Occurrence_Of (Predef_Prims, Loc),
4166              Attribute_Name => Name_Address));
4167
4168          --  Note: The correct value of Offset_To_Top will be set by the init
4169          --  subprogram
4170
4171          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4172
4173          --  Generate the Object Specific Data table required to dispatch calls
4174          --  through synchronized interfaces.
4175
4176          if Empty_DT
4177            or else Is_Abstract_Type (Typ)
4178            or else Is_Controlled (Typ)
4179            or else Restriction_Active (No_Dispatching_Calls)
4180            or else not Is_Limited_Type (Typ)
4181            or else not Has_Interfaces (Typ)
4182            or else not Build_Thunks
4183            or else not RTE_Record_Component_Available (RE_OSD_Table)
4184          then
4185             --  No OSD table required
4186
4187             Append_To (DT_Aggr_List,
4188               New_Occurrence_Of (RTE (RE_Null_Address), Loc));
4189
4190          else
4191             OSD_Aggr_List := New_List;
4192
4193             declare
4194                Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4195                Prim       : Entity_Id;
4196                Prim_Alias : Entity_Id;
4197                Prim_Elmt  : Elmt_Id;
4198                E          : Entity_Id;
4199                Count      : Nat := 0;
4200                Pos        : Nat;
4201
4202             begin
4203                Prim_Table := (others => Empty);
4204                Prim_Alias := Empty;
4205
4206                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4207                while Present (Prim_Elmt) loop
4208                   Prim := Node (Prim_Elmt);
4209
4210                   if Present (Interface_Alias (Prim))
4211                     and then Find_Dispatching_Type
4212                                (Interface_Alias (Prim)) = Iface
4213                   then
4214                      Prim_Alias := Interface_Alias (Prim);
4215                      E   := Ultimate_Alias (Prim);
4216                      Pos := UI_To_Int (DT_Position (Prim_Alias));
4217
4218                      if Present (Prim_Table (Pos)) then
4219                         pragma Assert (Prim_Table (Pos) = E);
4220                         null;
4221
4222                      else
4223                         Prim_Table (Pos) := E;
4224
4225                         Append_To (OSD_Aggr_List,
4226                           Make_Component_Association (Loc,
4227                             Choices => New_List (
4228                               Make_Integer_Literal (Loc,
4229                                 DT_Position (Prim_Alias))),
4230                             Expression =>
4231                               Make_Integer_Literal (Loc,
4232                                 DT_Position (Alias (Prim)))));
4233
4234                         Count := Count + 1;
4235                      end if;
4236                   end if;
4237
4238                   Next_Elmt (Prim_Elmt);
4239                end loop;
4240                pragma Assert (Count = Nb_Prim);
4241             end;
4242
4243             OSD := Make_Temporary (Loc, 'I');
4244
4245             Append_To (Result,
4246               Make_Object_Declaration (Loc,
4247                 Defining_Identifier => OSD,
4248                 Object_Definition   =>
4249                   Make_Subtype_Indication (Loc,
4250                     Subtype_Mark =>
4251                       New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc),
4252                     Constraint =>
4253                       Make_Index_Or_Discriminant_Constraint (Loc,
4254                         Constraints => New_List (
4255                           Make_Integer_Literal (Loc, Nb_Prim)))),
4256
4257                 Expression          =>
4258                   Make_Aggregate (Loc,
4259                     Component_Associations => New_List (
4260                       Make_Component_Association (Loc,
4261                         Choices => New_List (
4262                           New_Occurrence_Of
4263                             (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
4264                         Expression =>
4265                           Make_Integer_Literal (Loc, Nb_Prim)),
4266
4267                       Make_Component_Association (Loc,
4268                         Choices => New_List (
4269                           New_Occurrence_Of
4270                             (RTE_Record_Component (RE_OSD_Table), Loc)),
4271                         Expression => Make_Aggregate (Loc,
4272                           Component_Associations => OSD_Aggr_List))))));
4273
4274             Append_To (Result,
4275               Make_Attribute_Definition_Clause (Loc,
4276                 Name       => New_Occurrence_Of (OSD, Loc),
4277                 Chars      => Name_Alignment,
4278                 Expression =>
4279                   Make_Attribute_Reference (Loc,
4280                     Prefix =>
4281                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4282                     Attribute_Name => Name_Alignment)));
4283
4284             --  In secondary dispatch tables the Typeinfo component contains
4285             --  the address of the Object Specific Data (see a-tags.ads)
4286
4287             Append_To (DT_Aggr_List,
4288               Make_Attribute_Reference (Loc,
4289                 Prefix => New_Occurrence_Of (OSD, Loc),
4290                 Attribute_Name => Name_Address));
4291          end if;
4292
4293          --  Initialize the table of primitive operations
4294
4295          Prim_Ops_Aggr_List := New_List;
4296
4297          if Empty_DT then
4298             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4299
4300          elsif Is_Abstract_Type (Typ)
4301            or else not Building_Static_DT (Typ)
4302          then
4303             for J in 1 .. Nb_Prim loop
4304                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4305             end loop;
4306
4307          else
4308             declare
4309                CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
4310                E            : Entity_Id;
4311                Prim_Pos     : Nat;
4312                Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4313                Thunk_Code   : Node_Id;
4314                Thunk_Id     : Entity_Id;
4315
4316             begin
4317                Prim_Table := (others => Empty);
4318
4319                Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
4320                while Present (Prim_Elmt) loop
4321                   Prim     := Node (Prim_Elmt);
4322                   E        := Ultimate_Alias (Prim);
4323                   Prim_Pos := UI_To_Int (DT_Position (E));
4324
4325                   --  Do not reference predefined primitives because they are
4326                   --  located in a separate dispatch table; skip abstract and
4327                   --  eliminated primitives; skip primitives located in the C++
4328                   --  part of the dispatch table because their slot is set by
4329                   --  the IC routine.
4330
4331                   if not Is_Predefined_Dispatching_Operation (Prim)
4332                     and then Present (Interface_Alias (Prim))
4333                     and then not Is_Abstract_Subprogram (Alias (Prim))
4334                     and then not Is_Eliminated (Alias (Prim))
4335                     and then (not Is_CPP_Class (Root_Type (Typ))
4336                                or else Prim_Pos > CPP_Nb_Prims)
4337                     and then Find_Dispatching_Type
4338                                (Interface_Alias (Prim)) = Iface
4339
4340                      --  Generate the code of the thunk only if the abstract
4341                      --  interface type is not an immediate ancestor of
4342                      --  Tagged_Type. Otherwise the DT associated with the
4343                      --  interface is the primary DT.
4344
4345                     and then not Is_Ancestor (Iface, Typ,
4346                                               Use_Full_View => True)
4347                   then
4348                      if not Build_Thunks then
4349                         Prim_Pos :=
4350                           UI_To_Int (DT_Position (Interface_Alias (Prim)));
4351                         Prim_Table (Prim_Pos) := Alias (Prim);
4352
4353                      else
4354                         Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
4355
4356                         if Present (Thunk_Id) then
4357                            Prim_Pos :=
4358                              UI_To_Int (DT_Position (Interface_Alias (Prim)));
4359
4360                            Prim_Table (Prim_Pos) := Thunk_Id;
4361                            Append_To (Result, Thunk_Code);
4362                         end if;
4363                      end if;
4364                   end if;
4365
4366                   Next_Elmt (Prim_Elmt);
4367                end loop;
4368
4369                for J in Prim_Table'Range loop
4370                   if Present (Prim_Table (J)) then
4371                      New_Node :=
4372                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4373                          Make_Attribute_Reference (Loc,
4374                            Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
4375                            Attribute_Name => Name_Unrestricted_Access));
4376
4377                   else
4378                      New_Node := Make_Null (Loc);
4379                   end if;
4380
4381                   Append_To (Prim_Ops_Aggr_List, New_Node);
4382                end loop;
4383             end;
4384          end if;
4385
4386          New_Node :=
4387            Make_Aggregate (Loc,
4388              Expressions => Prim_Ops_Aggr_List);
4389
4390          Append_To (DT_Aggr_List, New_Node);
4391
4392          --  Remember aggregates initializing dispatch tables
4393
4394          Append_Elmt (New_Node, DT_Aggr);
4395
4396          --  Note: Secondary dispatch tables cannot be declared constant
4397          --  because the component Offset_To_Top is currently initialized
4398          --  by the IP routine.
4399
4400          Append_To (Result,
4401            Make_Object_Declaration (Loc,
4402              Defining_Identifier => Iface_DT,
4403              Aliased_Present     => True,
4404              Constant_Present    => False,
4405
4406              Object_Definition   =>
4407                Make_Subtype_Indication (Loc,
4408                  Subtype_Mark => New_Occurrence_Of
4409                                    (RTE (RE_Dispatch_Table_Wrapper), Loc),
4410                  Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
4411                                    Constraints => DT_Constr_List)),
4412
4413              Expression          =>
4414                Make_Aggregate (Loc,
4415                  Expressions => DT_Aggr_List)));
4416
4417          Append_To (Result,
4418            Make_Attribute_Definition_Clause (Loc,
4419              Name       => New_Occurrence_Of (Iface_DT, Loc),
4420              Chars      => Name_Alignment,
4421
4422              Expression =>
4423                Make_Attribute_Reference (Loc,
4424                  Prefix         =>
4425                    New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4426                  Attribute_Name => Name_Alignment)));
4427
4428          if Exporting_Table then
4429             Export_DT (Typ, Iface_DT, Suffix_Index);
4430
4431          --  Generate code to create the pointer to the dispatch table
4432
4433          --    Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4434
4435          --  Note: This declaration is not added here if the table is exported
4436          --  because in such case Make_Tags has already added this declaration.
4437
4438          else
4439             Append_To (Result,
4440               Make_Object_Declaration (Loc,
4441                 Defining_Identifier => Iface_DT_Ptr,
4442                 Constant_Present    => True,
4443
4444                 Object_Definition   =>
4445                   New_Occurrence_Of (RTE (RE_Interface_Tag), Loc),
4446
4447                 Expression          =>
4448                   Unchecked_Convert_To (RTE (RE_Interface_Tag),
4449                     Make_Attribute_Reference (Loc,
4450                       Prefix         =>
4451                         Make_Selected_Component (Loc,
4452                           Prefix        => New_Occurrence_Of (Iface_DT, Loc),
4453                           Selector_Name =>
4454                             New_Occurrence_Of
4455                               (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4456                       Attribute_Name => Name_Address))));
4457          end if;
4458
4459          Append_To (Result,
4460            Make_Object_Declaration (Loc,
4461              Defining_Identifier => Predef_Prims_Ptr,
4462              Constant_Present    => True,
4463
4464              Object_Definition   =>
4465                New_Occurrence_Of (RTE (RE_Address), Loc),
4466
4467              Expression          =>
4468                Make_Attribute_Reference (Loc,
4469                  Prefix         =>
4470                    Make_Selected_Component (Loc,
4471                      Prefix        => New_Occurrence_Of (Iface_DT, Loc),
4472                      Selector_Name =>
4473                        New_Occurrence_Of
4474                          (RTE_Record_Component (RE_Predef_Prims), Loc)),
4475                  Attribute_Name => Name_Address)));
4476
4477          --  Remember entities containing dispatch tables
4478
4479          Append_Elmt (Predef_Prims, DT_Decl);
4480          Append_Elmt (Iface_DT, DT_Decl);
4481       end Make_Secondary_DT;
4482
4483       --  Local variables
4484
4485       Elab_Code          : constant List_Id := New_List;
4486       Result             : constant List_Id := New_List;
4487       Tname              : constant Name_Id := Chars (Typ);
4488       AI                 : Elmt_Id;
4489       AI_Tag_Elmt        : Elmt_Id;
4490       AI_Tag_Comp        : Elmt_Id;
4491       DT_Aggr_List       : List_Id;
4492       DT_Constr_List     : List_Id;
4493       DT_Ptr             : Entity_Id;
4494       ITable             : Node_Id;
4495       I_Depth            : Nat := 0;
4496       Iface_Table_Node   : Node_Id;
4497       Name_ITable        : Name_Id;
4498       Nb_Predef_Prims    : Nat := 0;
4499       Nb_Prim            : Nat := 0;
4500       New_Node           : Node_Id;
4501       Num_Ifaces         : Nat := 0;
4502       Parent_Typ         : Entity_Id;
4503       Prim               : Entity_Id;
4504       Prim_Elmt          : Elmt_Id;
4505       Prim_Ops_Aggr_List : List_Id;
4506       Suffix_Index       : Int;
4507       Typ_Comps          : Elist_Id;
4508       Typ_Ifaces         : Elist_Id;
4509       TSD_Aggr_List      : List_Id;
4510       TSD_Tags_List      : List_Id;
4511
4512       --  The following name entries are used by Make_DT to generate a number
4513       --  of entities related to a tagged type. These entities may be generated
4514       --  in a scope other than that of the tagged type declaration, and if
4515       --  the entities for two tagged types with the same name happen to be
4516       --  generated in the same scope, we have to take care to use different
4517       --  names. This is achieved by means of a unique serial number appended
4518       --  to each generated entity name.
4519
4520       Name_DT           : constant Name_Id :=
4521                             New_External_Name (Tname, 'T', Suffix_Index => -1);
4522       Name_Exname       : constant Name_Id :=
4523                             New_External_Name (Tname, 'E', Suffix_Index => -1);
4524       Name_HT_Link      : constant Name_Id :=
4525                             New_External_Name (Tname, 'H', Suffix_Index => -1);
4526       Name_Predef_Prims : constant Name_Id :=
4527                             New_External_Name (Tname, 'R', Suffix_Index => -1);
4528       Name_SSD          : constant Name_Id :=
4529                             New_External_Name (Tname, 'S', Suffix_Index => -1);
4530       Name_TSD          : constant Name_Id :=
4531                             New_External_Name (Tname, 'B', Suffix_Index => -1);
4532
4533       --  Entities built with above names
4534
4535       DT           : constant Entity_Id :=
4536                        Make_Defining_Identifier (Loc, Name_DT);
4537       Exname       : constant Entity_Id :=
4538                        Make_Defining_Identifier (Loc, Name_Exname);
4539       HT_Link      : constant Entity_Id :=
4540                        Make_Defining_Identifier (Loc, Name_HT_Link);
4541       Predef_Prims : constant Entity_Id :=
4542                        Make_Defining_Identifier (Loc, Name_Predef_Prims);
4543       SSD          : constant Entity_Id :=
4544                        Make_Defining_Identifier (Loc, Name_SSD);
4545       TSD          : constant Entity_Id :=
4546                        Make_Defining_Identifier (Loc, Name_TSD);
4547
4548    --  Start of processing for Make_DT
4549
4550    begin
4551       pragma Assert (Is_Frozen (Typ));
4552
4553       --  Handle cases in which there is no need to build the dispatch table
4554
4555       if Has_Dispatch_Table (Typ)
4556         or else No (Access_Disp_Table (Typ))
4557         or else Is_CPP_Class (Typ)
4558         or else Convention (Typ) = Convention_CIL
4559         or else Convention (Typ) = Convention_Java
4560       then
4561          return Result;
4562
4563       elsif No_Run_Time_Mode then
4564          Error_Msg_CRT ("tagged types", Typ);
4565          return Result;
4566
4567       elsif not RTE_Available (RE_Tag) then
4568          Append_To (Result,
4569            Make_Object_Declaration (Loc,
4570              Defining_Identifier => Node (First_Elmt
4571                                            (Access_Disp_Table (Typ))),
4572              Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
4573              Constant_Present    => True,
4574              Expression =>
4575                Unchecked_Convert_To (RTE (RE_Tag),
4576                  New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
4577
4578          Analyze_List (Result, Suppress => All_Checks);
4579          Error_Msg_CRT ("tagged types", Typ);
4580          return Result;
4581       end if;
4582
4583       --  Ensure that the value of Max_Predef_Prims defined in a-tags is
4584       --  correct. Valid values are 9 under configurable runtime or 15
4585       --  with full runtime.
4586
4587       if RTE_Available (RE_Interface_Data) then
4588          if Max_Predef_Prims /= 15 then
4589             Error_Msg_N ("run-time library configuration error", Typ);
4590             return Result;
4591          end if;
4592       else
4593          if Max_Predef_Prims /= 9 then
4594             Error_Msg_N ("run-time library configuration error", Typ);
4595             Error_Msg_CRT ("tagged types", Typ);
4596             return Result;
4597          end if;
4598       end if;
4599
4600       --  Initialize Parent_Typ handling private types
4601
4602       Parent_Typ := Etype (Typ);
4603
4604       if Present (Full_View (Parent_Typ)) then
4605          Parent_Typ := Full_View (Parent_Typ);
4606       end if;
4607
4608       --  Ensure that all the primitives are frozen. This is only required when
4609       --  building static dispatch tables --- the primitives must be frozen to
4610       --  be referenced (otherwise we have problems with the backend). It is
4611       --  not a requirement with nonstatic dispatch tables because in this case
4612       --  we generate now an empty dispatch table; the extra code required to
4613       --  register the primitives in the slots will be generated later --- when
4614       --  each primitive is frozen (see Freeze_Subprogram).
4615
4616       if Building_Static_DT (Typ) then
4617          declare
4618             Save      : constant Boolean := Freezing_Library_Level_Tagged_Type;
4619             Prim      : Entity_Id;
4620             Prim_Elmt : Elmt_Id;
4621             Frnodes   : List_Id;
4622
4623          begin
4624             Freezing_Library_Level_Tagged_Type := True;
4625
4626             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4627             while Present (Prim_Elmt) loop
4628                Prim    := Node (Prim_Elmt);
4629                Frnodes := Freeze_Entity (Prim, Typ);
4630
4631                declare
4632                   F : Entity_Id;
4633
4634                begin
4635                   F := First_Formal (Prim);
4636                   while Present (F) loop
4637                      Check_Premature_Freezing (Prim, Typ, Etype (F));
4638                      Next_Formal (F);
4639                   end loop;
4640
4641                   Check_Premature_Freezing (Prim, Typ, Etype (Prim));
4642                end;
4643
4644                if Present (Frnodes) then
4645                   Append_List_To (Result, Frnodes);
4646                end if;
4647
4648                Next_Elmt (Prim_Elmt);
4649             end loop;
4650
4651             Freezing_Library_Level_Tagged_Type := Save;
4652          end;
4653       end if;
4654
4655       --  Ada 2005 (AI-251): Build the secondary dispatch tables
4656
4657       if Has_Interfaces (Typ) then
4658          Collect_Interface_Components (Typ, Typ_Comps);
4659
4660          --  Each secondary dispatch table is assigned an unique positive
4661          --  suffix index; such value also corresponds with the location of
4662          --  its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4663
4664          --  Note: This value must be kept sync with the Suffix_Index values
4665          --  generated by Make_Tags
4666
4667          Suffix_Index := 1;
4668          AI_Tag_Elmt  :=
4669            Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4670
4671          AI_Tag_Comp := First_Elmt (Typ_Comps);
4672          while Present (AI_Tag_Comp) loop
4673             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
4674
4675             --  Build the secondary table containing pointers to thunks
4676
4677             Make_Secondary_DT
4678              (Typ             => Typ,
4679               Iface           => Base_Type (Related_Type (Node (AI_Tag_Comp))),
4680               Suffix_Index    => Suffix_Index,
4681               Num_Iface_Prims => UI_To_Int
4682                                    (DT_Entry_Count (Node (AI_Tag_Comp))),
4683               Iface_DT_Ptr    => Node (AI_Tag_Elmt),
4684               Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4685               Build_Thunks    => True,
4686               Result          => Result);
4687
4688             --  Skip secondary dispatch table referencing thunks to predefined
4689             --  primitives.
4690
4691             Next_Elmt (AI_Tag_Elmt);
4692             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
4693
4694             --  Secondary dispatch table referencing user-defined primitives
4695             --  covered by this interface.
4696
4697             Next_Elmt (AI_Tag_Elmt);
4698             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
4699
4700             --  Build the secondary table containing pointers to primitives
4701             --  (used to give support to Generic Dispatching Constructors).
4702
4703             Make_Secondary_DT
4704               (Typ              => Typ,
4705                Iface            => Base_Type
4706                                      (Related_Type (Node (AI_Tag_Comp))),
4707                Suffix_Index     => -1,
4708                Num_Iface_Prims  => UI_To_Int
4709                                      (DT_Entry_Count (Node (AI_Tag_Comp))),
4710                Iface_DT_Ptr     => Node (AI_Tag_Elmt),
4711                Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4712                Build_Thunks     => False,
4713                Result           => Result);
4714
4715             --  Skip secondary dispatch table referencing predefined primitives
4716
4717             Next_Elmt (AI_Tag_Elmt);
4718             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
4719
4720             Suffix_Index := Suffix_Index + 1;
4721             Next_Elmt (AI_Tag_Elmt);
4722             Next_Elmt (AI_Tag_Comp);
4723          end loop;
4724       end if;
4725
4726       --  Get the _tag entity and number of primitives of its dispatch table
4727
4728       DT_Ptr  := Node (First_Elmt (Access_Disp_Table (Typ)));
4729       Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
4730
4731       Set_Is_Statically_Allocated (DT,  Is_Library_Level_Tagged_Type (Typ));
4732       Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
4733       Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
4734       Set_Is_Statically_Allocated (Predef_Prims,
4735         Is_Library_Level_Tagged_Type (Typ));
4736
4737       --  In case of locally defined tagged type we declare the object
4738       --  containing the dispatch table by means of a variable. Its
4739       --  initialization is done later by means of an assignment. This is
4740       --  required to generate its External_Tag.
4741
4742       if not Building_Static_DT (Typ) then
4743
4744          --  Generate:
4745          --    DT     : No_Dispatch_Table_Wrapper;
4746          --    for DT'Alignment use Address'Alignment;
4747          --    DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4748
4749          if not Has_DT (Typ) then
4750             Append_To (Result,
4751               Make_Object_Declaration (Loc,
4752                 Defining_Identifier => DT,
4753                 Aliased_Present     => True,
4754                 Constant_Present    => False,
4755                 Object_Definition   =>
4756                   New_Occurrence_Of
4757                     (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
4758
4759             Append_To (Result,
4760               Make_Attribute_Definition_Clause (Loc,
4761                 Name       => New_Occurrence_Of (DT, Loc),
4762                 Chars      => Name_Alignment,
4763                 Expression =>
4764                   Make_Attribute_Reference (Loc,
4765                     Prefix =>
4766                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4767                     Attribute_Name => Name_Alignment)));
4768
4769             Append_To (Result,
4770               Make_Object_Declaration (Loc,
4771                 Defining_Identifier => DT_Ptr,
4772                 Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
4773                 Constant_Present    => True,
4774                 Expression =>
4775                   Unchecked_Convert_To (RTE (RE_Tag),
4776                     Make_Attribute_Reference (Loc,
4777                       Prefix =>
4778                         Make_Selected_Component (Loc,
4779                           Prefix => New_Occurrence_Of (DT, Loc),
4780                         Selector_Name =>
4781                           New_Occurrence_Of
4782                             (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4783                       Attribute_Name => Name_Address))));
4784
4785             Set_Is_Statically_Allocated (DT_Ptr,
4786               Is_Library_Level_Tagged_Type (Typ));
4787
4788             --  Generate the SCIL node for the previous object declaration
4789             --  because it has a tag initialization.
4790
4791             if Generate_SCIL then
4792                New_Node :=
4793                  Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4794                Set_SCIL_Entity (New_Node, Typ);
4795                Set_SCIL_Node (Last (Result), New_Node);
4796             end if;
4797
4798          --  Generate:
4799          --    DT : Dispatch_Table_Wrapper (Nb_Prim);
4800          --    for DT'Alignment use Address'Alignment;
4801          --    DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4802
4803          else
4804             --  If the tagged type has no primitives we add a dummy slot
4805             --  whose address will be the tag of this type.
4806
4807             if Nb_Prim = 0 then
4808                DT_Constr_List :=
4809                  New_List (Make_Integer_Literal (Loc, 1));
4810             else
4811                DT_Constr_List :=
4812                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
4813             end if;
4814
4815             Append_To (Result,
4816               Make_Object_Declaration (Loc,
4817                 Defining_Identifier => DT,
4818                 Aliased_Present     => True,
4819                 Constant_Present    => False,
4820                 Object_Definition   =>
4821                   Make_Subtype_Indication (Loc,
4822                     Subtype_Mark =>
4823                       New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
4824                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4825                                     Constraints => DT_Constr_List))));
4826
4827             Append_To (Result,
4828               Make_Attribute_Definition_Clause (Loc,
4829                 Name       => New_Occurrence_Of (DT, Loc),
4830                 Chars      => Name_Alignment,
4831                 Expression =>
4832                   Make_Attribute_Reference (Loc,
4833                     Prefix =>
4834                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
4835                     Attribute_Name => Name_Alignment)));
4836
4837             Append_To (Result,
4838               Make_Object_Declaration (Loc,
4839                 Defining_Identifier => DT_Ptr,
4840                 Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
4841                 Constant_Present    => True,
4842                 Expression =>
4843                   Unchecked_Convert_To (RTE (RE_Tag),
4844                     Make_Attribute_Reference (Loc,
4845                       Prefix =>
4846                         Make_Selected_Component (Loc,
4847                           Prefix => New_Occurrence_Of (DT, Loc),
4848                         Selector_Name =>
4849                           New_Occurrence_Of
4850                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4851                       Attribute_Name => Name_Address))));
4852
4853             Set_Is_Statically_Allocated (DT_Ptr,
4854               Is_Library_Level_Tagged_Type (Typ));
4855
4856             --  Generate the SCIL node for the previous object declaration
4857             --  because it has a tag initialization.
4858
4859             if Generate_SCIL then
4860                New_Node :=
4861                  Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
4862                Set_SCIL_Entity (New_Node, Typ);
4863                Set_SCIL_Node (Last (Result), New_Node);
4864             end if;
4865
4866             Append_To (Result,
4867               Make_Object_Declaration (Loc,
4868                 Defining_Identifier =>
4869                   Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
4870                 Constant_Present    => True,
4871                 Object_Definition   => New_Occurrence_Of
4872                                             (RTE (RE_Address), Loc),
4873                 Expression =>
4874                   Make_Attribute_Reference (Loc,
4875                     Prefix =>
4876                       Make_Selected_Component (Loc,
4877                         Prefix => New_Occurrence_Of (DT, Loc),
4878                       Selector_Name =>
4879                         New_Occurrence_Of
4880                           (RTE_Record_Component (RE_Predef_Prims), Loc)),
4881                     Attribute_Name => Name_Address)));
4882          end if;
4883       end if;
4884
4885       --  Generate: Exname : constant String := full_qualified_name (typ);
4886       --  The type itself may be an anonymous parent type, so use the first
4887       --  subtype to have a user-recognizable name.
4888
4889       Append_To (Result,
4890         Make_Object_Declaration (Loc,
4891           Defining_Identifier => Exname,
4892           Constant_Present    => True,
4893           Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
4894           Expression =>
4895             Make_String_Literal (Loc,
4896               Fully_Qualified_Name_String (First_Subtype (Typ)))));
4897
4898       Set_Is_Statically_Allocated (Exname);
4899       Set_Is_True_Constant (Exname);
4900
4901       --  Declare the object used by Ada.Tags.Register_Tag
4902
4903       if RTE_Available (RE_Register_Tag) then
4904          Append_To (Result,
4905            Make_Object_Declaration (Loc,
4906              Defining_Identifier => HT_Link,
4907              Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc)));
4908       end if;
4909
4910       --  Generate code to create the storage for the type specific data object
4911       --  with enough space to store the tags of the ancestors plus the tags
4912       --  of all the implemented interfaces (as described in a-tags.adb).
4913
4914       --   TSD : Type_Specific_Data (I_Depth) :=
4915       --           (Idepth             => I_Depth,
4916       --            Access_Level       => Type_Access_Level (Typ),
4917       --            Alignment          => Typ'Alignment,
4918       --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
4919       --            External_Tag       => Cstring_Ptr!(Exname'Address))
4920       --            HT_Link            => HT_Link'Address,
4921       --            Transportable      => <<boolean-value>>,
4922       --            Type_Is_Abstract   => <<boolean-value>>,
4923       --            Needs_Finalization => <<boolean-value>>,
4924       --            [ Size_Func         => Size_Prim'Access, ]
4925       --            [ Interfaces_Table  => <<access-value>>, ]
4926       --            [ SSD               => SSD_Table'Address ]
4927       --            Tags_Table         => (0 => null,
4928       --                                   1 => Parent'Tag
4929       --                                   ...);
4930       --   for TSD'Alignment use Address'Alignment
4931
4932       TSD_Aggr_List := New_List;
4933
4934       --  Idepth: Count ancestors to compute the inheritance depth. For private
4935       --  extensions, always go to the full view in order to compute the real
4936       --  inheritance depth.
4937
4938       declare
4939          Current_Typ : Entity_Id;
4940          Parent_Typ  : Entity_Id;
4941
4942       begin
4943          I_Depth     := 0;
4944          Current_Typ := Typ;
4945          loop
4946             Parent_Typ := Etype (Current_Typ);
4947
4948             if Is_Private_Type (Parent_Typ) then
4949                Parent_Typ := Full_View (Base_Type (Parent_Typ));
4950             end if;
4951
4952             exit when Parent_Typ = Current_Typ;
4953
4954             I_Depth := I_Depth + 1;
4955             Current_Typ := Parent_Typ;
4956          end loop;
4957       end;
4958
4959       Append_To (TSD_Aggr_List,
4960         Make_Integer_Literal (Loc, I_Depth));
4961
4962       --  Access_Level
4963
4964       Append_To (TSD_Aggr_List,
4965         Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
4966
4967       --  Alignment
4968
4969       --  For CPP types we cannot rely on the value of 'Alignment provided
4970       --  by the backend to initialize this TSD field.
4971
4972       if Convention (Typ) = Convention_CPP
4973         or else Is_CPP_Class (Root_Type (Typ))
4974       then
4975          Append_To (TSD_Aggr_List,
4976            Make_Integer_Literal (Loc, 0));
4977       else
4978          Append_To (TSD_Aggr_List,
4979            Make_Attribute_Reference (Loc,
4980              Prefix => New_Occurrence_Of (Typ, Loc),
4981              Attribute_Name => Name_Alignment));
4982       end if;
4983
4984       --  Expanded_Name
4985
4986       Append_To (TSD_Aggr_List,
4987         Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4988           Make_Attribute_Reference (Loc,
4989             Prefix         => New_Occurrence_Of (Exname, Loc),
4990             Attribute_Name => Name_Address)));
4991
4992       --  External_Tag of a local tagged type
4993
4994       --     <typ>A : constant String :=
4995       --                "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4996
4997       --  The reason we generate this strange name is that we do not want to
4998       --  enter local tagged types in the global hash table used to compute
4999       --  the Internal_Tag attribute for two reasons:
5000
5001       --    1. It is hard to avoid a tasking race condition for entering the
5002       --    entry into the hash table.
5003
5004       --    2. It would cause a storage leak, unless we rig up considerable
5005       --    mechanism to remove the entry from the hash table on exit.
5006
5007       --  So what we do is to generate the above external tag name, where the
5008       --  hex address is the address of the local dispatch table (i.e. exactly
5009       --  the value we want if Internal_Tag is computed from this string).
5010
5011       --  Of course this value will only be valid if the tagged type is still
5012       --  in scope, but it clearly must be erroneous to compute the internal
5013       --  tag of a tagged type that is out of scope.
5014
5015       --  We don't do this processing if an explicit external tag has been
5016       --  specified. That's an odd case for which we have already issued a
5017       --  warning, where we will not be able to compute the internal tag.
5018
5019       if not Is_Library_Level_Entity (Typ)
5020         and then not Has_External_Tag_Rep_Clause (Typ)
5021       then
5022          declare
5023             Exname      : constant Entity_Id :=
5024                             Make_Defining_Identifier (Loc,
5025                               New_External_Name (Tname, 'A'));
5026
5027             Full_Name   : constant String_Id :=
5028                             Fully_Qualified_Name_String (First_Subtype (Typ));
5029             Str1_Id     : String_Id;
5030             Str2_Id     : String_Id;
5031
5032          begin
5033             --  Generate:
5034             --    Str1 = "Internal tag at 16#";
5035
5036             Start_String;
5037             Store_String_Chars ("Internal tag at 16#");
5038             Str1_Id := End_String;
5039
5040             --  Generate:
5041             --    Str2 = "#: <type-full-name>";
5042
5043             Start_String;
5044             Store_String_Chars ("#: ");
5045             Store_String_Chars (Full_Name);
5046             Str2_Id := End_String;
5047
5048             --  Generate:
5049             --    Exname : constant String :=
5050             --               Str1 & Address_Image (Tag) & Str2;
5051
5052             if RTE_Available (RE_Address_Image) then
5053                Append_To (Result,
5054                  Make_Object_Declaration (Loc,
5055                    Defining_Identifier => Exname,
5056                    Constant_Present    => True,
5057                    Object_Definition   => New_Occurrence_Of
5058                                             (Standard_String, Loc),
5059                    Expression =>
5060                      Make_Op_Concat (Loc,
5061                        Left_Opnd =>
5062                          Make_String_Literal (Loc, Str1_Id),
5063                        Right_Opnd =>
5064                          Make_Op_Concat (Loc,
5065                            Left_Opnd =>
5066                              Make_Function_Call (Loc,
5067                                Name =>
5068                                  New_Occurrence_Of
5069                                    (RTE (RE_Address_Image), Loc),
5070                                Parameter_Associations => New_List (
5071                                  Unchecked_Convert_To (RTE (RE_Address),
5072                                    New_Occurrence_Of (DT_Ptr, Loc)))),
5073                            Right_Opnd =>
5074                              Make_String_Literal (Loc, Str2_Id)))));
5075
5076             else
5077                Append_To (Result,
5078                  Make_Object_Declaration (Loc,
5079                    Defining_Identifier => Exname,
5080                    Constant_Present    => True,
5081                    Object_Definition   => New_Occurrence_Of
5082                                             (Standard_String, Loc),
5083                    Expression =>
5084                      Make_Op_Concat (Loc,
5085                        Left_Opnd =>
5086                          Make_String_Literal (Loc, Str1_Id),
5087                        Right_Opnd =>
5088                          Make_String_Literal (Loc, Str2_Id))));
5089             end if;
5090
5091             New_Node :=
5092               Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5093                 Make_Attribute_Reference (Loc,
5094                   Prefix => New_Occurrence_Of (Exname, Loc),
5095                   Attribute_Name => Name_Address));
5096          end;
5097
5098       --  External tag of a library-level tagged type: Check for a definition
5099       --  of External_Tag. The clause is considered only if it applies to this
5100       --  specific tagged type, as opposed to one of its ancestors.
5101       --  If the type is an unconstrained type extension, we are building the
5102       --  dispatch table of its anonymous base type, so the external tag, if
5103       --  any was specified, must be retrieved from the first subtype. Go to
5104       --  the full view in case the clause is in the private part.
5105
5106       else
5107          declare
5108             Def : constant Node_Id := Get_Attribute_Definition_Clause
5109                                         (Underlying_Type (First_Subtype (Typ)),
5110                                          Attribute_External_Tag);
5111
5112             Old_Val : String_Id;
5113             New_Val : String_Id;
5114             E       : Entity_Id;
5115
5116          begin
5117             if not Present (Def)
5118               or else Entity (Name (Def)) /= First_Subtype (Typ)
5119             then
5120                New_Node :=
5121                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5122                    Make_Attribute_Reference (Loc,
5123                      Prefix         => New_Occurrence_Of (Exname, Loc),
5124                      Attribute_Name => Name_Address));
5125             else
5126                Old_Val := Strval (Expr_Value_S (Expression (Def)));
5127
5128                --  For the rep clause "for <typ>'external_tag use y" generate:
5129
5130                --     <typ>A : constant string := y;
5131                --
5132                --  <typ>A'Address is used to set the External_Tag component
5133                --  of the TSD
5134
5135                --  Create a new nul terminated string if it is not already
5136
5137                if String_Length (Old_Val) > 0
5138                  and then
5139                   Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
5140                then
5141                   New_Val := Old_Val;
5142                else
5143                   Start_String (Old_Val);
5144                   Store_String_Char (Get_Char_Code (ASCII.NUL));
5145                   New_Val := End_String;
5146                end if;
5147
5148                E := Make_Defining_Identifier (Loc,
5149                       New_External_Name (Chars (Typ), 'A'));
5150
5151                Append_To (Result,
5152                  Make_Object_Declaration (Loc,
5153                    Defining_Identifier => E,
5154                    Constant_Present    => True,
5155                    Object_Definition   =>
5156                      New_Occurrence_Of (Standard_String, Loc),
5157                    Expression          =>
5158                      Make_String_Literal (Loc, New_Val)));
5159
5160                New_Node :=
5161                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
5162                    Make_Attribute_Reference (Loc,
5163                      Prefix => New_Occurrence_Of (E, Loc),
5164                      Attribute_Name => Name_Address));
5165             end if;
5166          end;
5167       end if;
5168
5169       Append_To (TSD_Aggr_List, New_Node);
5170
5171       --  HT_Link
5172
5173       if RTE_Available (RE_Register_Tag) then
5174          Append_To (TSD_Aggr_List,
5175            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5176              Make_Attribute_Reference (Loc,
5177                Prefix => New_Occurrence_Of (HT_Link, Loc),
5178                Attribute_Name => Name_Address)));
5179       else
5180          Append_To (TSD_Aggr_List,
5181            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
5182              New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5183       end if;
5184
5185       --  Transportable: Set for types that can be used in remote calls
5186       --  with respect to E.4(18) legality rules.
5187
5188       declare
5189          Transportable : Entity_Id;
5190
5191       begin
5192          Transportable :=
5193            Boolean_Literals
5194              (Is_Pure (Typ)
5195                 or else Is_Shared_Passive (Typ)
5196                 or else
5197                   ((Is_Remote_Types (Typ)
5198                       or else Is_Remote_Call_Interface (Typ))
5199                    and then Original_View_In_Visible_Part (Typ))
5200                 or else not Comes_From_Source (Typ));
5201
5202          Append_To (TSD_Aggr_List,
5203             New_Occurrence_Of (Transportable, Loc));
5204       end;
5205
5206       --  Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is
5207       --  not available in the HIE runtime.
5208
5209       if RTE_Record_Component_Available (RE_Type_Is_Abstract) then
5210          declare
5211             Type_Is_Abstract : Entity_Id;
5212
5213          begin
5214             Type_Is_Abstract :=
5215               Boolean_Literals (Is_Abstract_Type (Typ));
5216
5217             Append_To (TSD_Aggr_List,
5218                New_Occurrence_Of (Type_Is_Abstract, Loc));
5219          end;
5220       end if;
5221
5222       --  Needs_Finalization: Set if the type is controlled or has controlled
5223       --  components.
5224
5225       declare
5226          Needs_Fin : Entity_Id;
5227
5228       begin
5229          Needs_Fin := Boolean_Literals (Needs_Finalization (Typ));
5230          Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc));
5231       end;
5232
5233       --  Size_Func
5234
5235       if RTE_Record_Component_Available (RE_Size_Func) then
5236
5237          --  Initialize this field to Null_Address if we are not building
5238          --  static dispatch tables static or if the size function is not
5239          --  available. In the former case we cannot initialize this field
5240          --  until the function is frozen and registered in the dispatch
5241          --  table (see Register_Primitive).
5242
5243          if not Building_Static_DT (Typ) or else not Has_DT (Typ) then
5244             Append_To (TSD_Aggr_List,
5245               Unchecked_Convert_To (RTE (RE_Size_Ptr),
5246                 New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5247
5248          else
5249             declare
5250                Prim_Elmt : Elmt_Id;
5251                Prim      : Entity_Id;
5252                Size_Comp : Node_Id;
5253
5254             begin
5255                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5256                while Present (Prim_Elmt) loop
5257                   Prim := Node (Prim_Elmt);
5258
5259                   if Chars (Prim) = Name_uSize then
5260                      Prim := Ultimate_Alias (Prim);
5261
5262                      if Is_Abstract_Subprogram (Prim) then
5263                         Size_Comp :=
5264                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
5265                             New_Occurrence_Of (RTE (RE_Null_Address), Loc));
5266                      else
5267                         Size_Comp :=
5268                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
5269                             Make_Attribute_Reference (Loc,
5270                               Prefix => New_Occurrence_Of (Prim, Loc),
5271                               Attribute_Name => Name_Unrestricted_Access));
5272                      end if;
5273
5274                      exit;
5275                   end if;
5276
5277                   Next_Elmt (Prim_Elmt);
5278                end loop;
5279
5280                pragma Assert (Present (Size_Comp));
5281                Append_To (TSD_Aggr_List, Size_Comp);
5282             end;
5283          end if;
5284       end if;
5285
5286       --  Interfaces_Table (required for AI-405)
5287
5288       if RTE_Record_Component_Available (RE_Interfaces_Table) then
5289
5290          --  Count the number of interface types implemented by Typ
5291
5292          Collect_Interfaces (Typ, Typ_Ifaces);
5293
5294          AI := First_Elmt (Typ_Ifaces);
5295          while Present (AI) loop
5296             Num_Ifaces := Num_Ifaces + 1;
5297             Next_Elmt (AI);
5298          end loop;
5299
5300          if Num_Ifaces = 0 then
5301             Iface_Table_Node := Make_Null (Loc);
5302
5303          --  Generate the Interface_Table object
5304
5305          else
5306             declare
5307                TSD_Ifaces_List : constant List_Id := New_List;
5308                Elmt       : Elmt_Id;
5309                Sec_DT_Tag : Node_Id;
5310
5311             begin
5312                AI := First_Elmt (Typ_Ifaces);
5313                while Present (AI) loop
5314                   if Is_Ancestor (Node (AI), Typ, Use_Full_View => True) then
5315                      Sec_DT_Tag :=
5316                        New_Occurrence_Of (DT_Ptr, Loc);
5317                   else
5318                      Elmt :=
5319                        Next_Elmt
5320                         (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5321                      pragma Assert (Has_Thunks (Node (Elmt)));
5322
5323                      while Is_Tag (Node (Elmt))
5324                         and then not
5325                           Is_Ancestor (Node (AI), Related_Type (Node (Elmt)),
5326                                        Use_Full_View => True)
5327                      loop
5328                         pragma Assert (Has_Thunks (Node (Elmt)));
5329                         Next_Elmt (Elmt);
5330                         pragma Assert (Has_Thunks (Node (Elmt)));
5331                         Next_Elmt (Elmt);
5332                         pragma Assert (not Has_Thunks (Node (Elmt)));
5333                         Next_Elmt (Elmt);
5334                         pragma Assert (not Has_Thunks (Node (Elmt)));
5335                         Next_Elmt (Elmt);
5336                      end loop;
5337
5338                      pragma Assert (Ekind (Node (Elmt)) = E_Constant
5339                        and then not
5340                          Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
5341                      Sec_DT_Tag :=
5342                        New_Occurrence_Of (Node (Next_Elmt (Next_Elmt (Elmt))),
5343                                          Loc);
5344                   end if;
5345
5346                   Append_To (TSD_Ifaces_List,
5347                      Make_Aggregate (Loc,
5348                        Expressions => New_List (
5349
5350                         --  Iface_Tag
5351
5352                         Unchecked_Convert_To (RTE (RE_Tag),
5353                           New_Occurrence_Of
5354                             (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
5355                              Loc)),
5356
5357                         --  Static_Offset_To_Top
5358
5359                         New_Occurrence_Of (Standard_True, Loc),
5360
5361                         --  Offset_To_Top_Value
5362
5363                         Make_Integer_Literal (Loc, 0),
5364
5365                         --  Offset_To_Top_Func
5366
5367                         Make_Null (Loc),
5368
5369                         --  Secondary_DT
5370
5371                         Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
5372
5373                         )));
5374
5375                   Next_Elmt (AI);
5376                end loop;
5377
5378                Name_ITable := New_External_Name (Tname, 'I');
5379                ITable      := Make_Defining_Identifier (Loc, Name_ITable);
5380                Set_Is_Statically_Allocated (ITable,
5381                  Is_Library_Level_Tagged_Type (Typ));
5382
5383                --  The table of interfaces is not constant; its slots are
5384                --  filled at run time by the IP routine using attribute
5385                --  'Position to know the location of the tag components
5386                --  (and this attribute cannot be safely used before the
5387                --  object is initialized).
5388
5389                Append_To (Result,
5390                  Make_Object_Declaration (Loc,
5391                    Defining_Identifier => ITable,
5392                    Aliased_Present     => True,
5393                    Constant_Present    => False,
5394                    Object_Definition   =>
5395                      Make_Subtype_Indication (Loc,
5396                        Subtype_Mark =>
5397                          New_Occurrence_Of (RTE (RE_Interface_Data), Loc),
5398                        Constraint => Make_Index_Or_Discriminant_Constraint
5399                          (Loc,
5400                           Constraints => New_List (
5401                             Make_Integer_Literal (Loc, Num_Ifaces)))),
5402
5403                    Expression => Make_Aggregate (Loc,
5404                      Expressions => New_List (
5405                        Make_Integer_Literal (Loc, Num_Ifaces),
5406                        Make_Aggregate (Loc,
5407                          Expressions => TSD_Ifaces_List)))));
5408
5409                Append_To (Result,
5410                  Make_Attribute_Definition_Clause (Loc,
5411                    Name       => New_Occurrence_Of (ITable, Loc),
5412                    Chars      => Name_Alignment,
5413                    Expression =>
5414                      Make_Attribute_Reference (Loc,
5415                        Prefix =>
5416                          New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5417                        Attribute_Name => Name_Alignment)));
5418
5419                Iface_Table_Node :=
5420                  Make_Attribute_Reference (Loc,
5421                    Prefix         => New_Occurrence_Of (ITable, Loc),
5422                    Attribute_Name => Name_Unchecked_Access);
5423             end;
5424          end if;
5425
5426          Append_To (TSD_Aggr_List, Iface_Table_Node);
5427       end if;
5428
5429       --  Generate the Select Specific Data table for synchronized types that
5430       --  implement synchronized interfaces. The size of the table is
5431       --  constrained by the number of non-predefined primitive operations.
5432
5433       if RTE_Record_Component_Available (RE_SSD) then
5434          if Ada_Version >= Ada_2005
5435            and then Has_DT (Typ)
5436            and then Is_Concurrent_Record_Type (Typ)
5437            and then Has_Interfaces (Typ)
5438            and then Nb_Prim > 0
5439            and then not Is_Abstract_Type (Typ)
5440            and then not Is_Controlled (Typ)
5441            and then not Restriction_Active (No_Dispatching_Calls)
5442            and then not Restriction_Active (No_Select_Statements)
5443          then
5444             Append_To (Result,
5445               Make_Object_Declaration (Loc,
5446                 Defining_Identifier => SSD,
5447                 Aliased_Present     => True,
5448                 Object_Definition   =>
5449                   Make_Subtype_Indication (Loc,
5450                     Subtype_Mark => New_Occurrence_Of (
5451                       RTE (RE_Select_Specific_Data), Loc),
5452                     Constraint   =>
5453                       Make_Index_Or_Discriminant_Constraint (Loc,
5454                         Constraints => New_List (
5455                           Make_Integer_Literal (Loc, Nb_Prim))))));
5456
5457             Append_To (Result,
5458               Make_Attribute_Definition_Clause (Loc,
5459                 Name       => New_Occurrence_Of (SSD, Loc),
5460                 Chars      => Name_Alignment,
5461                 Expression =>
5462                   Make_Attribute_Reference (Loc,
5463                     Prefix =>
5464                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5465                     Attribute_Name => Name_Alignment)));
5466
5467             --  This table is initialized by Make_Select_Specific_Data_Table,
5468             --  which calls Set_Entry_Index and Set_Prim_Op_Kind.
5469
5470             Append_To (TSD_Aggr_List,
5471               Make_Attribute_Reference (Loc,
5472                 Prefix => New_Occurrence_Of (SSD, Loc),
5473                 Attribute_Name => Name_Unchecked_Access));
5474          else
5475             Append_To (TSD_Aggr_List, Make_Null (Loc));
5476          end if;
5477       end if;
5478
5479       --  Initialize the table of ancestor tags. In case of interface types
5480       --  this table is not needed.
5481
5482       TSD_Tags_List := New_List;
5483
5484       --  If we are not statically allocating the dispatch table then we must
5485       --  fill position 0 with null because we still have not generated the
5486       --  tag of Typ.
5487
5488       if not Building_Static_DT (Typ)
5489         or else Is_Interface (Typ)
5490       then
5491          Append_To (TSD_Tags_List,
5492            Unchecked_Convert_To (RTE (RE_Tag),
5493              New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5494
5495       --  Otherwise we can safely reference the tag
5496
5497       else
5498          Append_To (TSD_Tags_List,
5499            New_Occurrence_Of (DT_Ptr, Loc));
5500       end if;
5501
5502       --  Fill the rest of the table with the tags of the ancestors
5503
5504       declare
5505          Current_Typ : Entity_Id;
5506          Parent_Typ  : Entity_Id;
5507          Pos         : Nat;
5508
5509       begin
5510          Pos := 1;
5511          Current_Typ := Typ;
5512
5513          loop
5514             Parent_Typ := Etype (Current_Typ);
5515
5516             if Is_Private_Type (Parent_Typ) then
5517                Parent_Typ := Full_View (Base_Type (Parent_Typ));
5518             end if;
5519
5520             exit when Parent_Typ = Current_Typ;
5521
5522             if Is_CPP_Class (Parent_Typ) then
5523
5524                --  The tags defined in the C++ side will be inherited when
5525                --  the object is constructed (Exp_Ch3.Build_Init_Procedure)
5526
5527                Append_To (TSD_Tags_List,
5528                  Unchecked_Convert_To (RTE (RE_Tag),
5529                    New_Occurrence_Of (RTE (RE_Null_Address), Loc)));
5530             else
5531                Append_To (TSD_Tags_List,
5532                  New_Occurrence_Of
5533                    (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
5534                     Loc));
5535             end if;
5536
5537             Pos := Pos + 1;
5538             Current_Typ := Parent_Typ;
5539          end loop;
5540
5541          pragma Assert (Pos = I_Depth + 1);
5542       end;
5543
5544       Append_To (TSD_Aggr_List,
5545         Make_Aggregate (Loc,
5546           Expressions => TSD_Tags_List));
5547
5548       --  Build the TSD object
5549
5550       Append_To (Result,
5551         Make_Object_Declaration (Loc,
5552           Defining_Identifier => TSD,
5553           Aliased_Present     => True,
5554           Constant_Present    => Building_Static_DT (Typ),
5555           Object_Definition   =>
5556             Make_Subtype_Indication (Loc,
5557               Subtype_Mark => New_Occurrence_Of (
5558                 RTE (RE_Type_Specific_Data), Loc),
5559               Constraint =>
5560                 Make_Index_Or_Discriminant_Constraint (Loc,
5561                   Constraints => New_List (
5562                     Make_Integer_Literal (Loc, I_Depth)))),
5563
5564           Expression => Make_Aggregate (Loc,
5565             Expressions => TSD_Aggr_List)));
5566
5567       Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
5568
5569       Append_To (Result,
5570         Make_Attribute_Definition_Clause (Loc,
5571           Name       => New_Occurrence_Of (TSD, Loc),
5572           Chars      => Name_Alignment,
5573           Expression =>
5574             Make_Attribute_Reference (Loc,
5575               Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5576               Attribute_Name => Name_Alignment)));
5577
5578       --  Initialize or declare the dispatch table object
5579
5580       if not Has_DT (Typ) then
5581          DT_Constr_List := New_List;
5582          DT_Aggr_List   := New_List;
5583
5584          --  Typeinfo
5585
5586          New_Node :=
5587            Make_Attribute_Reference (Loc,
5588              Prefix => New_Occurrence_Of (TSD, Loc),
5589              Attribute_Name => Name_Address);
5590
5591          Append_To (DT_Constr_List, New_Node);
5592          Append_To (DT_Aggr_List,   New_Copy (New_Node));
5593          Append_To (DT_Aggr_List,   Make_Integer_Literal (Loc, 0));
5594
5595          --  In case of locally defined tagged types we have already declared
5596          --  and uninitialized object for the dispatch table, which is now
5597          --  initialized by means of the following assignment:
5598
5599          --    DT := (TSD'Address, 0);
5600
5601          if not Building_Static_DT (Typ) then
5602             Append_To (Result,
5603               Make_Assignment_Statement (Loc,
5604                 Name => New_Occurrence_Of (DT, Loc),
5605                 Expression => Make_Aggregate (Loc,
5606                   Expressions => DT_Aggr_List)));
5607
5608          --  In case of library level tagged types we declare and export now
5609          --  the constant object containing the dummy dispatch table. There
5610          --  is no need to declare the tag here because it has been previously
5611          --  declared by Make_Tags
5612
5613          --   DT : aliased constant No_Dispatch_Table :=
5614          --          (NDT_TSD       => TSD'Address;
5615          --           NDT_Prims_Ptr => 0);
5616          --   for DT'Alignment use Address'Alignment;
5617
5618          else
5619             Append_To (Result,
5620               Make_Object_Declaration (Loc,
5621                 Defining_Identifier => DT,
5622                 Aliased_Present     => True,
5623                 Constant_Present    => True,
5624                 Object_Definition   =>
5625                   New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
5626                 Expression => Make_Aggregate (Loc,
5627                   Expressions => DT_Aggr_List)));
5628
5629             Append_To (Result,
5630               Make_Attribute_Definition_Clause (Loc,
5631                 Name       => New_Occurrence_Of (DT, Loc),
5632                 Chars      => Name_Alignment,
5633                 Expression =>
5634                   Make_Attribute_Reference (Loc,
5635                     Prefix =>
5636                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5637                     Attribute_Name => Name_Alignment)));
5638
5639             Export_DT (Typ, DT);
5640          end if;
5641
5642       --  Common case: Typ has a dispatch table
5643
5644       --  Generate:
5645
5646       --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5647       --                    (predef-prim-op-1'address,
5648       --                     predef-prim-op-2'address,
5649       --                     ...
5650       --                     predef-prim-op-n'address);
5651       --   for Predef_Prims'Alignment use Address'Alignment
5652
5653       --   DT : Dispatch_Table (Nb_Prims) :=
5654       --          (Signature => <sig-value>,
5655       --           Tag_Kind  => <tag_kind-value>,
5656       --           Predef_Prims => Predef_Prims'First'Address,
5657       --           Offset_To_Top => 0,
5658       --           TSD           => TSD'Address;
5659       --           Prims_Ptr     => (prim-op-1'address,
5660       --                             prim-op-2'address,
5661       --                             ...
5662       --                             prim-op-n'address));
5663       --   for DT'Alignment use Address'Alignment
5664
5665       else
5666          declare
5667             Pos : Nat;
5668
5669          begin
5670             if not Building_Static_DT (Typ) then
5671                Nb_Predef_Prims := Max_Predef_Prims;
5672
5673             else
5674                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5675                while Present (Prim_Elmt) loop
5676                   Prim := Node (Prim_Elmt);
5677
5678                   if Is_Predefined_Dispatching_Operation (Prim)
5679                     and then not Is_Abstract_Subprogram (Prim)
5680                   then
5681                      Pos := UI_To_Int (DT_Position (Prim));
5682
5683                      if Pos > Nb_Predef_Prims then
5684                         Nb_Predef_Prims := Pos;
5685                      end if;
5686                   end if;
5687
5688                   Next_Elmt (Prim_Elmt);
5689                end loop;
5690             end if;
5691
5692             declare
5693                Prim_Table : array
5694                               (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
5695                Decl       : Node_Id;
5696                E          : Entity_Id;
5697
5698             begin
5699                Prim_Ops_Aggr_List := New_List;
5700
5701                Prim_Table := (others => Empty);
5702
5703                if Building_Static_DT (Typ) then
5704                   Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
5705                   while Present (Prim_Elmt) loop
5706                      Prim := Node (Prim_Elmt);
5707
5708                      if Is_Predefined_Dispatching_Operation (Prim)
5709                        and then not Is_Abstract_Subprogram (Prim)
5710                        and then not Is_Eliminated (Prim)
5711                        and then not Present (Prim_Table
5712                                               (UI_To_Int (DT_Position (Prim))))
5713                      then
5714                         E := Ultimate_Alias (Prim);
5715                         pragma Assert (not Is_Abstract_Subprogram (E));
5716                         Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5717                      end if;
5718
5719                      Next_Elmt (Prim_Elmt);
5720                   end loop;
5721                end if;
5722
5723                for J in Prim_Table'Range loop
5724                   if Present (Prim_Table (J)) then
5725                      New_Node :=
5726                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5727                          Make_Attribute_Reference (Loc,
5728                            Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
5729                            Attribute_Name => Name_Unrestricted_Access));
5730                   else
5731                      New_Node := Make_Null (Loc);
5732                   end if;
5733
5734                   Append_To (Prim_Ops_Aggr_List, New_Node);
5735                end loop;
5736
5737                New_Node :=
5738                  Make_Aggregate (Loc,
5739                    Expressions => Prim_Ops_Aggr_List);
5740
5741                Decl :=
5742                  Make_Subtype_Declaration (Loc,
5743                    Defining_Identifier => Make_Temporary (Loc, 'S'),
5744                    Subtype_Indication  =>
5745                      New_Occurrence_Of (RTE (RE_Address_Array), Loc));
5746
5747                Append_To (Result, Decl);
5748
5749                Append_To (Result,
5750                  Make_Object_Declaration (Loc,
5751                    Defining_Identifier => Predef_Prims,
5752                    Aliased_Present     => True,
5753                    Constant_Present    => Building_Static_DT (Typ),
5754                    Object_Definition   => New_Occurrence_Of
5755                                            (Defining_Identifier (Decl), Loc),
5756                    Expression => New_Node));
5757
5758                --  Remember aggregates initializing dispatch tables
5759
5760                Append_Elmt (New_Node, DT_Aggr);
5761
5762                Append_To (Result,
5763                  Make_Attribute_Definition_Clause (Loc,
5764                    Name       => New_Occurrence_Of (Predef_Prims, Loc),
5765                    Chars      => Name_Alignment,
5766                    Expression =>
5767                      Make_Attribute_Reference (Loc,
5768                        Prefix =>
5769                          New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5770                        Attribute_Name => Name_Alignment)));
5771             end;
5772          end;
5773
5774          --  Stage 1: Initialize the discriminant and the record components
5775
5776          DT_Constr_List := New_List;
5777          DT_Aggr_List   := New_List;
5778
5779          --  Num_Prims. If the tagged type has no primitives we add a dummy
5780          --  slot whose address will be the tag of this type.
5781
5782          if Nb_Prim = 0 then
5783             New_Node := Make_Integer_Literal (Loc, 1);
5784          else
5785             New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5786          end if;
5787
5788          Append_To (DT_Constr_List, New_Node);
5789          Append_To (DT_Aggr_List,   New_Copy (New_Node));
5790
5791          --  Signature
5792
5793          if RTE_Record_Component_Available (RE_Signature) then
5794             Append_To (DT_Aggr_List,
5795               New_Occurrence_Of (RTE (RE_Primary_DT), Loc));
5796          end if;
5797
5798          --  Tag_Kind
5799
5800          if RTE_Record_Component_Available (RE_Tag_Kind) then
5801             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
5802          end if;
5803
5804          --  Predef_Prims
5805
5806          Append_To (DT_Aggr_List,
5807            Make_Attribute_Reference (Loc,
5808              Prefix => New_Occurrence_Of (Predef_Prims, Loc),
5809              Attribute_Name => Name_Address));
5810
5811          --  Offset_To_Top
5812
5813          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5814
5815          --  Typeinfo
5816
5817          Append_To (DT_Aggr_List,
5818            Make_Attribute_Reference (Loc,
5819              Prefix => New_Occurrence_Of (TSD, Loc),
5820              Attribute_Name => Name_Address));
5821
5822          --  Stage 2: Initialize the table of user-defined primitive operations
5823
5824          Prim_Ops_Aggr_List := New_List;
5825
5826          if Nb_Prim = 0 then
5827             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5828
5829          elsif not Building_Static_DT (Typ) then
5830             for J in 1 .. Nb_Prim loop
5831                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5832             end loop;
5833
5834          else
5835             declare
5836                CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
5837                E            : Entity_Id;
5838                Prim         : Entity_Id;
5839                Prim_Elmt    : Elmt_Id;
5840                Prim_Pos     : Nat;
5841                Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
5842
5843             begin
5844                Prim_Table := (others => Empty);
5845
5846                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5847                while Present (Prim_Elmt) loop
5848                   Prim := Node (Prim_Elmt);
5849
5850                   --  Retrieve the ultimate alias of the primitive for proper
5851                   --  handling of renamings and eliminated primitives.
5852
5853                   E        := Ultimate_Alias (Prim);
5854                   Prim_Pos := UI_To_Int (DT_Position (E));
5855
5856                   --  Do not reference predefined primitives because they are
5857                   --  located in a separate dispatch table; skip entities with
5858                   --  attribute Interface_Alias because they are only required
5859                   --  to build secondary dispatch tables; skip abstract and
5860                   --  eliminated primitives; for derivations of CPP types skip
5861                   --  primitives located in the C++ part of the dispatch table
5862                   --  because their slot is initialized by the IC routine.
5863
5864                   if not Is_Predefined_Dispatching_Operation (Prim)
5865                     and then not Is_Predefined_Dispatching_Operation (E)
5866                     and then not Present (Interface_Alias (Prim))
5867                     and then not Is_Abstract_Subprogram (E)
5868                     and then not Is_Eliminated (E)
5869                     and then (not Is_CPP_Class (Root_Type (Typ))
5870                                or else Prim_Pos > CPP_Nb_Prims)
5871                   then
5872                      pragma Assert
5873                        (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
5874
5875                      Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5876                   end if;
5877
5878                   Next_Elmt (Prim_Elmt);
5879                end loop;
5880
5881                for J in Prim_Table'Range loop
5882                   if Present (Prim_Table (J)) then
5883                      New_Node :=
5884                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5885                          Make_Attribute_Reference (Loc,
5886                            Prefix => New_Occurrence_Of (Prim_Table (J), Loc),
5887                            Attribute_Name => Name_Unrestricted_Access));
5888                   else
5889                      New_Node := Make_Null (Loc);
5890                   end if;
5891
5892                   Append_To (Prim_Ops_Aggr_List, New_Node);
5893                end loop;
5894             end;
5895          end if;
5896
5897          New_Node :=
5898            Make_Aggregate (Loc,
5899              Expressions => Prim_Ops_Aggr_List);
5900
5901          Append_To (DT_Aggr_List, New_Node);
5902
5903          --  Remember aggregates initializing dispatch tables
5904
5905          Append_Elmt (New_Node, DT_Aggr);
5906
5907          --  In case of locally defined tagged types we have already declared
5908          --  and uninitialized object for the dispatch table, which is now
5909          --  initialized by means of an assignment.
5910
5911          if not Building_Static_DT (Typ) then
5912             Append_To (Result,
5913               Make_Assignment_Statement (Loc,
5914                 Name => New_Occurrence_Of (DT, Loc),
5915                 Expression => Make_Aggregate (Loc,
5916                   Expressions => DT_Aggr_List)));
5917
5918          --  In case of library level tagged types we declare now and export
5919          --  the constant object containing the dispatch table.
5920
5921          else
5922             Append_To (Result,
5923               Make_Object_Declaration (Loc,
5924                 Defining_Identifier => DT,
5925                 Aliased_Present     => True,
5926                 Constant_Present    => True,
5927                 Object_Definition   =>
5928                   Make_Subtype_Indication (Loc,
5929                     Subtype_Mark => New_Occurrence_Of
5930                                       (RTE (RE_Dispatch_Table_Wrapper), Loc),
5931                     Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
5932                                       Constraints => DT_Constr_List)),
5933                 Expression => Make_Aggregate (Loc,
5934                   Expressions => DT_Aggr_List)));
5935
5936             Append_To (Result,
5937               Make_Attribute_Definition_Clause (Loc,
5938                 Name       => New_Occurrence_Of (DT, Loc),
5939                 Chars      => Name_Alignment,
5940                 Expression =>
5941                   Make_Attribute_Reference (Loc,
5942                     Prefix =>
5943                       New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
5944                     Attribute_Name => Name_Alignment)));
5945
5946             Export_DT (Typ, DT);
5947          end if;
5948       end if;
5949
5950       --  Initialize the table of ancestor tags if not building static
5951       --  dispatch table
5952
5953       if not Building_Static_DT (Typ)
5954         and then not Is_Interface (Typ)
5955         and then not Is_CPP_Class (Typ)
5956       then
5957          Append_To (Result,
5958            Make_Assignment_Statement (Loc,
5959              Name =>
5960                Make_Indexed_Component (Loc,
5961                  Prefix =>
5962                    Make_Selected_Component (Loc,
5963                      Prefix =>
5964                        New_Occurrence_Of (TSD, Loc),
5965                      Selector_Name =>
5966                        New_Occurrence_Of
5967                          (RTE_Record_Component (RE_Tags_Table), Loc)),
5968                  Expressions =>
5969                     New_List (Make_Integer_Literal (Loc, 0))),
5970
5971              Expression =>
5972                New_Occurrence_Of
5973                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
5974       end if;
5975
5976       --  Inherit the dispatch tables of the parent. There is no need to
5977       --  inherit anything from the parent when building static dispatch tables
5978       --  because the whole dispatch table (including inherited primitives) has
5979       --  been already built.
5980
5981       if Building_Static_DT (Typ) then
5982          null;
5983
5984       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
5985       --  in the init proc, and we don't need to fill them in here.
5986
5987       elsif Is_CPP_Class (Parent_Typ) then
5988          null;
5989
5990       --  Otherwise we fill in the dispatch tables here
5991
5992       else
5993          if Typ /= Parent_Typ
5994            and then not Is_Interface (Typ)
5995            and then not Restriction_Active (No_Dispatching_Calls)
5996          then
5997             --  Inherit the dispatch table
5998
5999             if not Is_Interface (Typ)
6000               and then not Is_Interface (Parent_Typ)
6001               and then not Is_CPP_Class (Parent_Typ)
6002             then
6003                declare
6004                   Nb_Prims : constant Int :=
6005                                UI_To_Int (DT_Entry_Count
6006                                  (First_Tag_Component (Parent_Typ)));
6007
6008                begin
6009                   Append_To (Elab_Code,
6010                     Build_Inherit_Predefined_Prims (Loc,
6011                       Old_Tag_Node =>
6012                         New_Occurrence_Of
6013                           (Node
6014                            (Next_Elmt
6015                             (First_Elmt
6016                              (Access_Disp_Table (Parent_Typ)))), Loc),
6017                       New_Tag_Node =>
6018                         New_Occurrence_Of
6019                           (Node
6020                            (Next_Elmt
6021                             (First_Elmt
6022                              (Access_Disp_Table (Typ)))), Loc)));
6023
6024                   if Nb_Prims /= 0 then
6025                      Append_To (Elab_Code,
6026                        Build_Inherit_Prims (Loc,
6027                          Typ          => Typ,
6028                          Old_Tag_Node =>
6029                            New_Occurrence_Of
6030                              (Node
6031                               (First_Elmt
6032                                (Access_Disp_Table (Parent_Typ))), Loc),
6033                          New_Tag_Node => New_Occurrence_Of (DT_Ptr, Loc),
6034                          Num_Prims    => Nb_Prims));
6035                   end if;
6036                end;
6037             end if;
6038
6039             --  Inherit the secondary dispatch tables of the ancestor
6040
6041             if not Is_CPP_Class (Parent_Typ) then
6042                declare
6043                   Sec_DT_Ancestor : Elmt_Id :=
6044                                       Next_Elmt
6045                                        (Next_Elmt
6046                                         (First_Elmt
6047                                           (Access_Disp_Table (Parent_Typ))));
6048                   Sec_DT_Typ      : Elmt_Id :=
6049                                       Next_Elmt
6050                                        (Next_Elmt
6051                                          (First_Elmt
6052                                            (Access_Disp_Table (Typ))));
6053
6054                   procedure Copy_Secondary_DTs (Typ : Entity_Id);
6055                   --  Local procedure required to climb through the ancestors
6056                   --  and copy the contents of all their secondary dispatch
6057                   --  tables.
6058
6059                   ------------------------
6060                   -- Copy_Secondary_DTs --
6061                   ------------------------
6062
6063                   procedure Copy_Secondary_DTs (Typ : Entity_Id) is
6064                      E     : Entity_Id;
6065                      Iface : Elmt_Id;
6066
6067                   begin
6068                      --  Climb to the ancestor (if any) handling private types
6069
6070                      if Present (Full_View (Etype (Typ))) then
6071                         if Full_View (Etype (Typ)) /= Typ then
6072                            Copy_Secondary_DTs (Full_View (Etype (Typ)));
6073                         end if;
6074
6075                      elsif Etype (Typ) /= Typ then
6076                         Copy_Secondary_DTs (Etype (Typ));
6077                      end if;
6078
6079                      if Present (Interfaces (Typ))
6080                        and then not Is_Empty_Elmt_List (Interfaces (Typ))
6081                      then
6082                         Iface := First_Elmt (Interfaces (Typ));
6083                         E     := First_Entity (Typ);
6084                         while Present (E)
6085                           and then Present (Node (Sec_DT_Ancestor))
6086                           and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6087                         loop
6088                            if Is_Tag (E) and then Chars (E) /= Name_uTag then
6089                               declare
6090                                  Num_Prims : constant Int :=
6091                                                UI_To_Int (DT_Entry_Count (E));
6092
6093                               begin
6094                                  if not Is_Interface (Etype (Typ)) then
6095
6096                                     --  Inherit first secondary dispatch table
6097
6098                                     Append_To (Elab_Code,
6099                                       Build_Inherit_Predefined_Prims (Loc,
6100                                         Old_Tag_Node =>
6101                                           Unchecked_Convert_To (RTE (RE_Tag),
6102                                             New_Occurrence_Of
6103                                               (Node
6104                                                 (Next_Elmt (Sec_DT_Ancestor)),
6105                                                Loc)),
6106                                         New_Tag_Node =>
6107                                           Unchecked_Convert_To (RTE (RE_Tag),
6108                                             New_Occurrence_Of
6109                                               (Node (Next_Elmt (Sec_DT_Typ)),
6110                                                Loc))));
6111
6112                                     if Num_Prims /= 0 then
6113                                        Append_To (Elab_Code,
6114                                          Build_Inherit_Prims (Loc,
6115                                            Typ          => Node (Iface),
6116                                            Old_Tag_Node =>
6117                                              Unchecked_Convert_To
6118                                                (RTE (RE_Tag),
6119                                                 New_Occurrence_Of
6120                                                   (Node (Sec_DT_Ancestor),
6121                                                    Loc)),
6122                                            New_Tag_Node =>
6123                                              Unchecked_Convert_To
6124                                               (RTE (RE_Tag),
6125                                                New_Occurrence_Of
6126                                                  (Node (Sec_DT_Typ), Loc)),
6127                                            Num_Prims    => Num_Prims));
6128                                     end if;
6129                                  end if;
6130
6131                                  Next_Elmt (Sec_DT_Ancestor);
6132                                  Next_Elmt (Sec_DT_Typ);
6133
6134                                  --  Skip the secondary dispatch table of
6135                                  --  predefined primitives
6136
6137                                  Next_Elmt (Sec_DT_Ancestor);
6138                                  Next_Elmt (Sec_DT_Typ);
6139
6140                                  if not Is_Interface (Etype (Typ)) then
6141
6142                                     --  Inherit second secondary dispatch table
6143
6144                                     Append_To (Elab_Code,
6145                                       Build_Inherit_Predefined_Prims (Loc,
6146                                         Old_Tag_Node =>
6147                                           Unchecked_Convert_To (RTE (RE_Tag),
6148                                              New_Occurrence_Of
6149                                                (Node
6150                                                  (Next_Elmt (Sec_DT_Ancestor)),
6151                                                 Loc)),
6152                                         New_Tag_Node =>
6153                                           Unchecked_Convert_To (RTE (RE_Tag),
6154                                             New_Occurrence_Of
6155                                               (Node (Next_Elmt (Sec_DT_Typ)),
6156                                                Loc))));
6157
6158                                     if Num_Prims /= 0 then
6159                                        Append_To (Elab_Code,
6160                                          Build_Inherit_Prims (Loc,
6161                                            Typ          => Node (Iface),
6162                                            Old_Tag_Node =>
6163                                              Unchecked_Convert_To
6164                                                (RTE (RE_Tag),
6165                                                 New_Occurrence_Of
6166                                                   (Node (Sec_DT_Ancestor),
6167                                                    Loc)),
6168                                            New_Tag_Node =>
6169                                              Unchecked_Convert_To
6170                                               (RTE (RE_Tag),
6171                                                New_Occurrence_Of
6172                                                  (Node (Sec_DT_Typ), Loc)),
6173                                            Num_Prims    => Num_Prims));
6174                                     end if;
6175                                  end if;
6176                               end;
6177
6178                               Next_Elmt (Sec_DT_Ancestor);
6179                               Next_Elmt (Sec_DT_Typ);
6180
6181                               --  Skip the secondary dispatch table of
6182                               --  predefined primitives
6183
6184                               Next_Elmt (Sec_DT_Ancestor);
6185                               Next_Elmt (Sec_DT_Typ);
6186
6187                               Next_Elmt (Iface);
6188                            end if;
6189
6190                            Next_Entity (E);
6191                         end loop;
6192                      end if;
6193                   end Copy_Secondary_DTs;
6194
6195                begin
6196                   if Present (Node (Sec_DT_Ancestor))
6197                     and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
6198                   then
6199                      --  Handle private types
6200
6201                      if Present (Full_View (Typ)) then
6202                         Copy_Secondary_DTs (Full_View (Typ));
6203                      else
6204                         Copy_Secondary_DTs (Typ);
6205                      end if;
6206                   end if;
6207                end;
6208             end if;
6209          end if;
6210       end if;
6211
6212       --  If the type has a representation clause which specifies its external
6213       --  tag then generate code to check if the external tag of this type is
6214       --  the same as the external tag of some other declaration.
6215
6216       --     Check_TSD (TSD'Unrestricted_Access);
6217
6218       --  This check is a consequence of AI05-0113-1/06, so it officially
6219       --  applies to Ada 2005 (and Ada 2012). It might be argued that it is
6220       --  a desirable check to add in Ada 95 mode, but we hesitate to make
6221       --  this change, as it would be incompatible, and could conceivably
6222       --  cause a problem in existing Aa 95 code.
6223
6224       --  We check for No_Run_Time_Mode here, because we do not want to pick
6225       --  up the RE_Check_TSD entity and call it in No_Run_Time mode.
6226
6227       if not No_Run_Time_Mode
6228         and then Ada_Version >= Ada_2005
6229         and then Has_External_Tag_Rep_Clause (Typ)
6230         and then RTE_Available (RE_Check_TSD)
6231         and then not Debug_Flag_QQ
6232       then
6233          Append_To (Elab_Code,
6234            Make_Procedure_Call_Statement (Loc,
6235              Name => New_Occurrence_Of (RTE (RE_Check_TSD), Loc),
6236              Parameter_Associations => New_List (
6237                Make_Attribute_Reference (Loc,
6238                  Prefix => New_Occurrence_Of (TSD, Loc),
6239                  Attribute_Name => Name_Unchecked_Access))));
6240       end if;
6241
6242       --  Generate code to register the Tag in the External_Tag hash table for
6243       --  the pure Ada type only.
6244
6245       --        Register_Tag (Dt_Ptr);
6246
6247       --  Skip this action in the following cases:
6248       --    1) if Register_Tag is not available.
6249       --    2) in No_Run_Time mode.
6250       --    3) if Typ is not defined at the library level (this is required
6251       --       to avoid adding concurrency control to the hash table used
6252       --       by the run-time to register the tags).
6253
6254       if not No_Run_Time_Mode
6255         and then Is_Library_Level_Entity (Typ)
6256         and then RTE_Available (RE_Register_Tag)
6257       then
6258          Append_To (Elab_Code,
6259            Make_Procedure_Call_Statement (Loc,
6260              Name => New_Occurrence_Of (RTE (RE_Register_Tag), Loc),
6261              Parameter_Associations =>
6262                New_List (New_Occurrence_Of (DT_Ptr, Loc))));
6263       end if;
6264
6265       if not Is_Empty_List (Elab_Code) then
6266          Append_List_To (Result, Elab_Code);
6267       end if;
6268
6269       --  Populate the two auxiliary tables used for dispatching asynchronous,
6270       --  conditional and timed selects for synchronized types that implement
6271       --  a limited interface. Skip this step in Ravenscar profile or when
6272       --  general dispatching is forbidden.
6273
6274       if Ada_Version >= Ada_2005
6275         and then Is_Concurrent_Record_Type (Typ)
6276         and then Has_Interfaces (Typ)
6277         and then not Restriction_Active (No_Dispatching_Calls)
6278         and then not Restriction_Active (No_Select_Statements)
6279       then
6280          Append_List_To (Result,
6281            Make_Select_Specific_Data_Table (Typ));
6282       end if;
6283
6284       --  Remember entities containing dispatch tables
6285
6286       Append_Elmt (Predef_Prims, DT_Decl);
6287       Append_Elmt (DT, DT_Decl);
6288
6289       Analyze_List (Result, Suppress => All_Checks);
6290       Set_Has_Dispatch_Table (Typ);
6291
6292       --  Mark entities containing dispatch tables. Required by the backend to
6293       --  handle them properly.
6294
6295       if Has_DT (Typ) then
6296          declare
6297             Elmt : Elmt_Id;
6298
6299          begin
6300             --  Object declarations
6301
6302             Elmt := First_Elmt (DT_Decl);
6303             while Present (Elmt) loop
6304                Set_Is_Dispatch_Table_Entity (Node (Elmt));
6305                pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
6306                  or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
6307                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6308                Next_Elmt (Elmt);
6309             end loop;
6310
6311             --  Aggregates initializing dispatch tables
6312
6313             Elmt := First_Elmt (DT_Aggr);
6314             while Present (Elmt) loop
6315                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6316                Next_Elmt (Elmt);
6317             end loop;
6318          end;
6319       end if;
6320
6321       --  Register the tagged type in the call graph nodes table
6322
6323       Register_CG_Node (Typ);
6324
6325       return Result;
6326    end Make_DT;
6327
6328    -----------------
6329    -- Make_VM_TSD --
6330    -----------------
6331
6332    function Make_VM_TSD (Typ : Entity_Id) return List_Id is
6333       Loc    : constant Source_Ptr := Sloc (Typ);
6334       Result : constant List_Id := New_List;
6335
6336       function Count_Primitives (Typ : Entity_Id) return Nat;
6337       --  Count the non-predefined primitive operations of Typ
6338
6339       ----------------------
6340       -- Count_Primitives --
6341       ----------------------
6342
6343       function Count_Primitives (Typ : Entity_Id) return Nat is
6344          Nb_Prim   : Nat;
6345          Prim_Elmt : Elmt_Id;
6346          Prim      : Entity_Id;
6347
6348       begin
6349          Nb_Prim := 0;
6350
6351          Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6352          while Present (Prim_Elmt) loop
6353             Prim := Node (Prim_Elmt);
6354
6355             if Is_Predefined_Dispatching_Operation (Prim)
6356               or else Is_Predefined_Dispatching_Alias (Prim)
6357             then
6358                null;
6359
6360             elsif Present (Interface_Alias (Prim)) then
6361                null;
6362
6363             else
6364                Nb_Prim := Nb_Prim + 1;
6365             end if;
6366
6367             Next_Elmt (Prim_Elmt);
6368          end loop;
6369
6370          return Nb_Prim;
6371       end Count_Primitives;
6372
6373       --------------
6374       -- Make_OSD --
6375       --------------
6376
6377       function Make_OSD (Iface : Entity_Id) return Node_Id;
6378       --  Generate the Object Specific Data table required to dispatch calls
6379       --  through synchronized interfaces. Returns a node that references the
6380       --  generated OSD object.
6381
6382       function Make_OSD (Iface : Entity_Id) return Node_Id is
6383          Nb_Prim       : constant Nat := Count_Primitives (Iface);
6384          OSD           : Entity_Id;
6385          OSD_Aggr_List : List_Id;
6386
6387       begin
6388          --  Generate
6389          --   OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
6390          --          (OSD_Table => (1 => <value>,
6391          --                           ...
6392          --                         N => <value>));
6393
6394          if Nb_Prim = 0
6395            or else Is_Abstract_Type (Typ)
6396            or else Is_Controlled (Typ)
6397            or else Restriction_Active (No_Dispatching_Calls)
6398            or else not Is_Limited_Type (Typ)
6399            or else not Has_Interfaces (Typ)
6400            or else not RTE_Record_Component_Available (RE_OSD_Table)
6401          then
6402             --  No OSD table required
6403
6404             return Make_Null (Loc);
6405
6406          else
6407             OSD_Aggr_List := New_List;
6408
6409             declare
6410                Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
6411                Prim       : Entity_Id;
6412                Prim_Alias : Entity_Id;
6413                Prim_Elmt  : Elmt_Id;
6414                E          : Entity_Id;
6415                Count      : Nat := 0;
6416                Pos        : Nat;
6417
6418             begin
6419                Prim_Table := (others => Empty);
6420                Prim_Alias := Empty;
6421
6422                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6423                while Present (Prim_Elmt) loop
6424                   Prim := Node (Prim_Elmt);
6425
6426                   if Present (Interface_Alias (Prim))
6427                     and then Find_Dispatching_Type
6428                                (Interface_Alias (Prim)) = Iface
6429                   then
6430                      Prim_Alias := Interface_Alias (Prim);
6431                      E   := Ultimate_Alias (Prim);
6432                      Pos := UI_To_Int (DT_Position (Prim_Alias));
6433
6434                      if Present (Prim_Table (Pos)) then
6435                         pragma Assert (Prim_Table (Pos) = E);
6436                         null;
6437
6438                      else
6439                         Prim_Table (Pos) := E;
6440
6441                         Append_To (OSD_Aggr_List,
6442                           Make_Component_Association (Loc,
6443                             Choices => New_List (
6444                               Make_Integer_Literal (Loc,
6445                                 DT_Position (Prim_Alias))),
6446                             Expression =>
6447                               Make_Integer_Literal (Loc,
6448                                 DT_Position (Alias (Prim)))));
6449
6450                         Count := Count + 1;
6451                      end if;
6452                   end if;
6453
6454                   Next_Elmt (Prim_Elmt);
6455                end loop;
6456                pragma Assert (Count = Nb_Prim);
6457             end;
6458
6459             OSD := Make_Temporary (Loc, 'I');
6460
6461             Append_To (Result,
6462               Make_Object_Declaration (Loc,
6463                 Defining_Identifier => OSD,
6464                 Aliased_Present     => True,
6465                 Constant_Present    => True,
6466                 Object_Definition   =>
6467                   Make_Subtype_Indication (Loc,
6468                     Subtype_Mark =>
6469                       New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc),
6470                     Constraint =>
6471                       Make_Index_Or_Discriminant_Constraint (Loc,
6472                         Constraints => New_List (
6473                           Make_Integer_Literal (Loc, Nb_Prim)))),
6474
6475                 Expression          =>
6476                   Make_Aggregate (Loc,
6477                     Component_Associations => New_List (
6478                       Make_Component_Association (Loc,
6479                         Choices => New_List (
6480                           New_Occurrence_Of
6481                             (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
6482                         Expression =>
6483                           Make_Integer_Literal (Loc, Nb_Prim)),
6484
6485                       Make_Component_Association (Loc,
6486                         Choices => New_List (
6487                           New_Occurrence_Of
6488                             (RTE_Record_Component (RE_OSD_Table), Loc)),
6489                         Expression => Make_Aggregate (Loc,
6490                           Component_Associations => OSD_Aggr_List))))));
6491
6492             return
6493               Make_Attribute_Reference (Loc,
6494                 Prefix => New_Occurrence_Of (OSD, Loc),
6495                 Attribute_Name => Name_Unchecked_Access);
6496          end if;
6497       end Make_OSD;
6498
6499       --  Local variables
6500
6501       Nb_Prim          : constant Nat := Count_Primitives (Typ);
6502       AI               : Elmt_Id;
6503       I_Depth          : Nat;
6504       Iface_Table_Node : Node_Id;
6505       Num_Ifaces       : Nat;
6506       TSD_Aggr_List    : List_Id;
6507       Typ_Ifaces       : Elist_Id;
6508       TSD_Tags_List    : List_Id;
6509
6510       Tname    : constant Name_Id := Chars (Typ);
6511       Name_SSD : constant Name_Id :=
6512                    New_External_Name (Tname, 'S', Suffix_Index => -1);
6513       Name_TSD : constant Name_Id :=
6514                    New_External_Name (Tname, 'B', Suffix_Index => -1);
6515       SSD      : constant Entity_Id :=
6516                    Make_Defining_Identifier (Loc, Name_SSD);
6517       TSD      : constant Entity_Id :=
6518                    Make_Defining_Identifier (Loc, Name_TSD);
6519    begin
6520       --  Generate code to create the storage for the type specific data object
6521       --  with enough space to store the tags of the ancestors plus the tags
6522       --  of all the implemented interfaces (as described in a-tags.ads).
6523
6524       --   TSD : Type_Specific_Data (I_Depth) :=
6525       --           (Idepth                => I_Depth,
6526       --            Tag_Kind              => <tag_kind-value>,
6527       --            Access_Level          => Type_Access_Level (Typ),
6528       --            Alignment             => Typ'Alignment,
6529       --            HT_Link               => null,
6530       --            Type_Is_Abstract      => <<boolean-value>>,
6531       --            Type_Is_Library_Level => <<boolean-value>>,
6532       --            Interfaces_Table      => <<access-value>>
6533       --            SSD                   => SSD_Table'Address
6534       --            Tags_Table            => (0 => Typ'Tag,
6535       --                                      1 => Parent'Tag
6536       --                                      ...));
6537
6538       TSD_Aggr_List := New_List;
6539
6540       --  Idepth: Count ancestors to compute the inheritance depth. For private
6541       --  extensions, always go to the full view in order to compute the real
6542       --  inheritance depth.
6543
6544       declare
6545          Current_Typ : Entity_Id;
6546          Parent_Typ  : Entity_Id;
6547
6548       begin
6549          I_Depth     := 0;
6550          Current_Typ := Typ;
6551          loop
6552             Parent_Typ := Etype (Current_Typ);
6553
6554             if Is_Private_Type (Parent_Typ) then
6555                Parent_Typ := Full_View (Base_Type (Parent_Typ));
6556             end if;
6557
6558             exit when Parent_Typ = Current_Typ;
6559
6560             I_Depth := I_Depth + 1;
6561             Current_Typ := Parent_Typ;
6562          end loop;
6563       end;
6564
6565       --  I_Depth
6566
6567       Append_To (TSD_Aggr_List,
6568         Make_Integer_Literal (Loc, I_Depth));
6569
6570       --  Tag_Kind
6571
6572       Append_To (TSD_Aggr_List, Tagged_Kind (Typ));
6573
6574       --  Access_Level
6575
6576       Append_To (TSD_Aggr_List,
6577         Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
6578
6579       --  Alignment
6580
6581       --  For CPP types we cannot rely on the value of 'Alignment provided
6582       --  by the backend to initialize this TSD field. Why not???
6583
6584       if Convention (Typ) = Convention_CPP
6585         or else Is_CPP_Class (Root_Type (Typ))
6586       then
6587          Append_To (TSD_Aggr_List,
6588            Make_Integer_Literal (Loc, 0));
6589       else
6590          Append_To (TSD_Aggr_List,
6591            Make_Attribute_Reference (Loc,
6592              Prefix         => New_Occurrence_Of (Typ, Loc),
6593              Attribute_Name => Name_Alignment));
6594       end if;
6595
6596       --  HT_Link
6597
6598       Append_To (TSD_Aggr_List,
6599         Make_Null (Loc));
6600
6601       --  Type_Is_Abstract (Ada 2012: AI05-0173)
6602
6603       declare
6604          Type_Is_Abstract : Entity_Id;
6605
6606       begin
6607          Type_Is_Abstract :=
6608            Boolean_Literals (Is_Abstract_Type (Typ));
6609
6610          Append_To (TSD_Aggr_List,
6611             New_Occurrence_Of (Type_Is_Abstract, Loc));
6612       end;
6613
6614       --  Type_Is_Library_Level
6615
6616       declare
6617          Type_Is_Library_Level : Entity_Id;
6618       begin
6619          Type_Is_Library_Level :=
6620            Boolean_Literals (Is_Library_Level_Entity (Typ));
6621          Append_To (TSD_Aggr_List,
6622             New_Occurrence_Of (Type_Is_Library_Level, Loc));
6623       end;
6624
6625       --  Interfaces_Table (required for AI-405)
6626
6627       if RTE_Record_Component_Available (RE_Interfaces_Table) then
6628
6629          --  Count the number of interface types implemented by Typ
6630
6631          Collect_Interfaces (Typ, Typ_Ifaces);
6632
6633          Num_Ifaces := 0;
6634          AI := First_Elmt (Typ_Ifaces);
6635          while Present (AI) loop
6636             Num_Ifaces := Num_Ifaces + 1;
6637             Next_Elmt (AI);
6638          end loop;
6639
6640          if Num_Ifaces = 0 then
6641             Iface_Table_Node := Make_Null (Loc);
6642
6643          --  Generate the Interface_Table object
6644
6645          else
6646             declare
6647                TSD_Ifaces_List : constant List_Id := New_List;
6648                Iface           : Entity_Id;
6649                ITable          : Node_Id;
6650
6651             begin
6652                AI := First_Elmt (Typ_Ifaces);
6653                while Present (AI) loop
6654                   Iface := Node (AI);
6655
6656                   Append_To (TSD_Ifaces_List,
6657                      Make_Aggregate (Loc,
6658                        Expressions => New_List (
6659
6660                          --  Iface_Tag
6661
6662                          Make_Attribute_Reference (Loc,
6663                            Prefix         => New_Occurrence_Of (Iface, Loc),
6664                            Attribute_Name => Name_Tag),
6665
6666                          --  OSD
6667
6668                          Make_OSD (Iface))));
6669
6670                   Next_Elmt (AI);
6671                end loop;
6672
6673                ITable := Make_Temporary (Loc, 'I');
6674
6675                Append_To (Result,
6676                  Make_Object_Declaration (Loc,
6677                    Defining_Identifier => ITable,
6678                    Aliased_Present     => True,
6679                    Constant_Present    => True,
6680                    Object_Definition   =>
6681                      Make_Subtype_Indication (Loc,
6682                        Subtype_Mark =>
6683                          New_Occurrence_Of (RTE (RE_Interface_Data), Loc),
6684                        Constraint   => Make_Index_Or_Discriminant_Constraint
6685                          (Loc,
6686                           Constraints => New_List (
6687                             Make_Integer_Literal (Loc, Num_Ifaces)))),
6688
6689                    Expression => Make_Aggregate (Loc,
6690                      Expressions => New_List (
6691                        Make_Integer_Literal (Loc, Num_Ifaces),
6692                        Make_Aggregate (Loc,
6693                          Expressions => TSD_Ifaces_List)))));
6694
6695                Iface_Table_Node :=
6696                  Make_Attribute_Reference (Loc,
6697                    Prefix         => New_Occurrence_Of (ITable, Loc),
6698                    Attribute_Name => Name_Unchecked_Access);
6699             end;
6700          end if;
6701
6702          Append_To (TSD_Aggr_List, Iface_Table_Node);
6703       end if;
6704
6705       --  Generate the Select Specific Data table for synchronized types that
6706       --  implement synchronized interfaces. The size of the table is
6707       --  constrained by the number of non-predefined primitive operations.
6708
6709       if RTE_Record_Component_Available (RE_SSD) then
6710          if Ada_Version >= Ada_2005
6711            and then Has_DT (Typ)
6712            and then Is_Concurrent_Record_Type (Typ)
6713            and then Has_Interfaces (Typ)
6714            and then Nb_Prim > 0
6715            and then not Is_Abstract_Type (Typ)
6716            and then not Is_Controlled (Typ)
6717            and then not Restriction_Active (No_Dispatching_Calls)
6718            and then not Restriction_Active (No_Select_Statements)
6719          then
6720             Append_To (Result,
6721               Make_Object_Declaration (Loc,
6722                 Defining_Identifier => SSD,
6723                 Aliased_Present     => True,
6724                 Object_Definition   =>
6725                   Make_Subtype_Indication (Loc,
6726                     Subtype_Mark => New_Occurrence_Of (
6727                       RTE (RE_Select_Specific_Data), Loc),
6728                     Constraint   =>
6729                       Make_Index_Or_Discriminant_Constraint (Loc,
6730                         Constraints => New_List (
6731                           Make_Integer_Literal (Loc, Nb_Prim))))));
6732
6733             --  This table is initialized by Make_Select_Specific_Data_Table,
6734             --  which calls Set_Entry_Index and Set_Prim_Op_Kind.
6735
6736             Append_To (TSD_Aggr_List,
6737               Make_Attribute_Reference (Loc,
6738                 Prefix         => New_Occurrence_Of (SSD, Loc),
6739                 Attribute_Name => Name_Unchecked_Access));
6740          else
6741             Append_To (TSD_Aggr_List, Make_Null (Loc));
6742          end if;
6743       end if;
6744
6745       --  Initialize the table of ancestor tags. In case of interface types
6746       --  this table is not needed.
6747
6748       TSD_Tags_List := New_List;
6749
6750       --  Fill position 0 with Typ'Tag
6751
6752       Append_To (TSD_Tags_List,
6753         Make_Attribute_Reference (Loc,
6754           Prefix         => New_Occurrence_Of (Typ, Loc),
6755           Attribute_Name => Name_Tag));
6756
6757       --  Fill the rest of the table with the tags of the ancestors
6758
6759       declare
6760          Current_Typ : Entity_Id;
6761          Parent_Typ  : Entity_Id;
6762          Pos         : Nat;
6763
6764       begin
6765          Pos := 1;
6766          Current_Typ := Typ;
6767
6768          loop
6769             Parent_Typ := Etype (Current_Typ);
6770
6771             if Is_Private_Type (Parent_Typ) then
6772                Parent_Typ := Full_View (Base_Type (Parent_Typ));
6773             end if;
6774
6775             exit when Parent_Typ = Current_Typ;
6776
6777             Append_To (TSD_Tags_List,
6778               Make_Attribute_Reference (Loc,
6779                 Prefix         => New_Occurrence_Of (Parent_Typ, Loc),
6780                 Attribute_Name => Name_Tag));
6781
6782             Pos := Pos + 1;
6783             Current_Typ := Parent_Typ;
6784          end loop;
6785
6786          pragma Assert (Pos = I_Depth + 1);
6787       end;
6788
6789       Append_To (TSD_Aggr_List,
6790         Make_Aggregate (Loc,
6791           Expressions => TSD_Tags_List));
6792
6793       --  Build the TSD object
6794
6795       Append_To (Result,
6796         Make_Object_Declaration (Loc,
6797           Defining_Identifier => TSD,
6798           Aliased_Present     => True,
6799           Constant_Present    => True,
6800           Object_Definition   =>
6801             Make_Subtype_Indication (Loc,
6802               Subtype_Mark => New_Occurrence_Of (
6803                 RTE (RE_Type_Specific_Data), Loc),
6804               Constraint =>
6805                 Make_Index_Or_Discriminant_Constraint (Loc,
6806                   Constraints => New_List (
6807                     Make_Integer_Literal (Loc, I_Depth)))),
6808
6809           Expression => Make_Aggregate (Loc,
6810             Expressions => TSD_Aggr_List)));
6811
6812       --  Generate:
6813       --     Check_TSD
6814       --       (TSD => TSD'Unrestricted_Access);
6815
6816       if Ada_Version >= Ada_2005
6817         and then Is_Library_Level_Entity (Typ)
6818         and then Has_External_Tag_Rep_Clause (Typ)
6819         and then RTE_Available (RE_Check_TSD)
6820         and then not Debug_Flag_QQ
6821       then
6822          Append_To (Result,
6823            Make_Procedure_Call_Statement (Loc,
6824              Name => New_Occurrence_Of (RTE (RE_Check_TSD), Loc),
6825              Parameter_Associations => New_List (
6826                Make_Attribute_Reference (Loc,
6827                  Prefix         => New_Occurrence_Of (TSD, Loc),
6828                  Attribute_Name => Name_Unrestricted_Access))));
6829       end if;
6830
6831       --  Generate:
6832       --     Register_TSD (TSD'Unrestricted_Access);
6833
6834       Append_To (Result,
6835         Make_Procedure_Call_Statement (Loc,
6836           Name => New_Occurrence_Of (RTE (RE_Register_TSD), Loc),
6837           Parameter_Associations => New_List (
6838             Make_Attribute_Reference (Loc,
6839               Prefix         => New_Occurrence_Of (TSD, Loc),
6840               Attribute_Name => Name_Unrestricted_Access))));
6841
6842       --  Populate the two auxiliary tables used for dispatching asynchronous,
6843       --  conditional and timed selects for synchronized types that implement
6844       --  a limited interface. Skip this step in Ravenscar profile or when
6845       --  general dispatching is forbidden.
6846
6847       if Ada_Version >= Ada_2005
6848         and then Is_Concurrent_Record_Type (Typ)
6849         and then Has_Interfaces (Typ)
6850         and then not Restriction_Active (No_Dispatching_Calls)
6851         and then not Restriction_Active (No_Select_Statements)
6852       then
6853          Append_List_To (Result,
6854            Make_Select_Specific_Data_Table (Typ));
6855       end if;
6856
6857       return Result;
6858    end Make_VM_TSD;
6859
6860    -------------------------------------
6861    -- Make_Select_Specific_Data_Table --
6862    -------------------------------------
6863
6864    function Make_Select_Specific_Data_Table
6865      (Typ : Entity_Id) return List_Id
6866    is
6867       Assignments : constant List_Id    := New_List;
6868       Loc         : constant Source_Ptr := Sloc (Typ);
6869
6870       Conc_Typ  : Entity_Id;
6871       Decls     : List_Id;
6872       Prim      : Entity_Id;
6873       Prim_Als  : Entity_Id;
6874       Prim_Elmt : Elmt_Id;
6875       Prim_Pos  : Uint;
6876       Nb_Prim   : Nat := 0;
6877
6878       type Examined_Array is array (Int range <>) of Boolean;
6879
6880       function Find_Entry_Index (E : Entity_Id) return Uint;
6881       --  Given an entry, find its index in the visible declarations of the
6882       --  corresponding concurrent type of Typ.
6883
6884       ----------------------
6885       -- Find_Entry_Index --
6886       ----------------------
6887
6888       function Find_Entry_Index (E : Entity_Id) return Uint is
6889          Index     : Uint := Uint_1;
6890          Subp_Decl : Entity_Id;
6891
6892       begin
6893          if Present (Decls)
6894            and then not Is_Empty_List (Decls)
6895          then
6896             Subp_Decl := First (Decls);
6897             while Present (Subp_Decl) loop
6898                if Nkind (Subp_Decl) = N_Entry_Declaration then
6899                   if Defining_Identifier (Subp_Decl) = E then
6900                      return Index;
6901                   end if;
6902
6903                   Index := Index + 1;
6904                end if;
6905
6906                Next (Subp_Decl);
6907             end loop;
6908          end if;
6909
6910          return Uint_0;
6911       end Find_Entry_Index;
6912
6913       --  Local variables
6914
6915       Tag_Node : Node_Id;
6916
6917    --  Start of processing for Make_Select_Specific_Data_Table
6918
6919    begin
6920       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6921
6922       if Present (Corresponding_Concurrent_Type (Typ)) then
6923          Conc_Typ := Corresponding_Concurrent_Type (Typ);
6924
6925          if Present (Full_View (Conc_Typ)) then
6926             Conc_Typ := Full_View (Conc_Typ);
6927          end if;
6928
6929          if Ekind (Conc_Typ) = E_Protected_Type then
6930             Decls := Visible_Declarations (Protected_Definition (
6931                        Parent (Conc_Typ)));
6932          else
6933             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6934             Decls := Visible_Declarations (Task_Definition (
6935                        Parent (Conc_Typ)));
6936          end if;
6937       end if;
6938
6939       --  Count the non-predefined primitive operations
6940
6941       Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6942       while Present (Prim_Elmt) loop
6943          Prim := Node (Prim_Elmt);
6944
6945          if not (Is_Predefined_Dispatching_Operation (Prim)
6946                    or else Is_Predefined_Dispatching_Alias (Prim))
6947          then
6948             Nb_Prim := Nb_Prim + 1;
6949          end if;
6950
6951          Next_Elmt (Prim_Elmt);
6952       end loop;
6953
6954       declare
6955          Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
6956
6957       begin
6958          Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6959          while Present (Prim_Elmt) loop
6960             Prim := Node (Prim_Elmt);
6961
6962             --  Look for primitive overriding an abstract interface subprogram
6963
6964             if Present (Interface_Alias (Prim))
6965               and then not
6966                 Is_Ancestor
6967                   (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
6968                    Use_Full_View => True)
6969               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
6970             then
6971                Prim_Pos := DT_Position (Alias (Prim));
6972                pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
6973                Examined (UI_To_Int (Prim_Pos)) := True;
6974
6975                --  Set the primitive operation kind regardless of subprogram
6976                --  type. Generate:
6977                --    Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6978
6979                if Tagged_Type_Expansion then
6980                   Tag_Node :=
6981                     New_Occurrence_Of
6982                      (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
6983
6984                else
6985                   Tag_Node :=
6986                     Make_Attribute_Reference (Loc,
6987                       Prefix         => New_Occurrence_Of (Typ, Loc),
6988                       Attribute_Name => Name_Tag);
6989                end if;
6990
6991                Append_To (Assignments,
6992                  Make_Procedure_Call_Statement (Loc,
6993                    Name => New_Occurrence_Of (RTE (RE_Set_Prim_Op_Kind), Loc),
6994                    Parameter_Associations => New_List (
6995                      Tag_Node,
6996                      Make_Integer_Literal (Loc, Prim_Pos),
6997                      Prim_Op_Kind (Alias (Prim), Typ))));
6998
6999                --  Retrieve the root of the alias chain
7000
7001                Prim_Als := Ultimate_Alias (Prim);
7002
7003                --  In the case of an entry wrapper, set the entry index
7004
7005                if Ekind (Prim) = E_Procedure
7006                  and then Is_Primitive_Wrapper (Prim_Als)
7007                  and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
7008                then
7009                   --  Generate:
7010                   --    Ada.Tags.Set_Entry_Index
7011                   --      (DT_Ptr, <position>, <index>);
7012
7013                   if Tagged_Type_Expansion then
7014                      Tag_Node :=
7015                        New_Occurrence_Of
7016                          (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
7017                   else
7018                      Tag_Node :=
7019                        Make_Attribute_Reference (Loc,
7020                          Prefix         => New_Occurrence_Of (Typ, Loc),
7021                          Attribute_Name => Name_Tag);
7022                   end if;
7023
7024                   Append_To (Assignments,
7025                     Make_Procedure_Call_Statement (Loc,
7026                       Name =>
7027                         New_Occurrence_Of (RTE (RE_Set_Entry_Index), Loc),
7028                       Parameter_Associations => New_List (
7029                         Tag_Node,
7030                         Make_Integer_Literal (Loc, Prim_Pos),
7031                         Make_Integer_Literal (Loc,
7032                           Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
7033                end if;
7034             end if;
7035
7036             Next_Elmt (Prim_Elmt);
7037          end loop;
7038       end;
7039
7040       return Assignments;
7041    end Make_Select_Specific_Data_Table;
7042
7043    ---------------
7044    -- Make_Tags --
7045    ---------------
7046
7047    function Make_Tags (Typ : Entity_Id) return List_Id is
7048       Loc    : constant Source_Ptr := Sloc (Typ);
7049       Result : constant List_Id    := New_List;
7050
7051       procedure Import_DT
7052         (Tag_Typ         : Entity_Id;
7053          DT              : Entity_Id;
7054          Is_Secondary_DT : Boolean);
7055       --  Import the dispatch table DT of tagged type Tag_Typ. Required to
7056       --  generate forward references and statically allocate the table. For
7057       --  primary dispatch tables that require no dispatch table generate:
7058
7059       --     DT : static aliased constant Non_Dispatch_Table_Wrapper;
7060       --     pragma Import (Ada, DT);
7061
7062       --  Otherwise generate:
7063
7064       --     DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
7065       --     pragma Import (Ada, DT);
7066
7067       ---------------
7068       -- Import_DT --
7069       ---------------
7070
7071       procedure Import_DT
7072         (Tag_Typ         : Entity_Id;
7073          DT              : Entity_Id;
7074          Is_Secondary_DT : Boolean)
7075       is
7076          DT_Constr_List : List_Id;
7077          Nb_Prim        : Nat;
7078
7079       begin
7080          Set_Is_Imported  (DT);
7081          Set_Ekind        (DT, E_Constant);
7082          Set_Related_Type (DT, Typ);
7083
7084          --  The scope must be set now to call Get_External_Name
7085
7086          Set_Scope (DT, Current_Scope);
7087
7088          Get_External_Name (DT);
7089          Set_Interface_Name (DT,
7090            Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
7091
7092          --  Ensure proper Sprint output of this implicit importation
7093
7094          Set_Is_Internal (DT);
7095
7096          --  Save this entity to allow Make_DT to generate its exportation
7097
7098          Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
7099
7100          --  No dispatch table required
7101
7102          if not Is_Secondary_DT and then not Has_DT (Tag_Typ) then
7103             Append_To (Result,
7104               Make_Object_Declaration (Loc,
7105                 Defining_Identifier => DT,
7106                 Aliased_Present     => True,
7107                 Constant_Present    => True,
7108                 Object_Definition   =>
7109                   New_Occurrence_Of
7110                     (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
7111
7112          else
7113             --  Calculate the number of primitives of the dispatch table and
7114             --  the size of the Type_Specific_Data record.
7115
7116             Nb_Prim :=
7117               UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
7118
7119             --  If the tagged type has no primitives we add a dummy slot whose
7120             --  address will be the tag of this type.
7121
7122             if Nb_Prim = 0 then
7123                DT_Constr_List :=
7124                  New_List (Make_Integer_Literal (Loc, 1));
7125             else
7126                DT_Constr_List :=
7127                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
7128             end if;
7129
7130             Append_To (Result,
7131               Make_Object_Declaration (Loc,
7132                 Defining_Identifier => DT,
7133                 Aliased_Present     => True,
7134                 Constant_Present    => True,
7135                 Object_Definition   =>
7136                   Make_Subtype_Indication (Loc,
7137                     Subtype_Mark =>
7138                       New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc),
7139                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
7140                                     Constraints => DT_Constr_List))));
7141          end if;
7142       end Import_DT;
7143
7144       --  Local variables
7145
7146       Tname            : constant Name_Id := Chars (Typ);
7147       AI_Tag_Comp      : Elmt_Id;
7148       DT               : Node_Id := Empty;
7149       DT_Ptr           : Node_Id;
7150       Predef_Prims_Ptr : Node_Id;
7151       Iface_DT         : Node_Id := Empty;
7152       Iface_DT_Ptr     : Node_Id;
7153       New_Node         : Node_Id;
7154       Suffix_Index     : Int;
7155       Typ_Name         : Name_Id;
7156       Typ_Comps        : Elist_Id;
7157
7158    --  Start of processing for Make_Tags
7159
7160    begin
7161       pragma Assert (No (Access_Disp_Table (Typ)));
7162       Set_Access_Disp_Table (Typ, New_Elmt_List);
7163
7164       --  1) Generate the primary tag entities
7165
7166       --  Primary dispatch table containing user-defined primitives
7167
7168       DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
7169       Set_Etype   (DT_Ptr, RTE (RE_Tag));
7170       Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
7171
7172       --  Minimum decoration
7173
7174       Set_Ekind        (DT_Ptr, E_Variable);
7175       Set_Related_Type (DT_Ptr, Typ);
7176
7177       --  Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
7178       --  the decoration required by the backend.
7179
7180       --  Odd comment, the back end cannot require anything not properly
7181       --  documented in einfo. ???
7182
7183       Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
7184       Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
7185
7186       --  For CPP types there is no need to build the dispatch tables since
7187       --  they are imported from the C++ side. If the CPP type has an IP then
7188       --  we declare now the variable that will store the copy of the C++ tag.
7189       --  If the CPP type is an interface, we need the variable as well because
7190       --  it becomes the pointer to the corresponding secondary table.
7191
7192       if Is_CPP_Class (Typ) then
7193          if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then
7194             Append_To (Result,
7195               Make_Object_Declaration (Loc,
7196                 Defining_Identifier => DT_Ptr,
7197                 Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
7198                 Expression =>
7199                   Unchecked_Convert_To (RTE (RE_Tag),
7200                     New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
7201
7202             Set_Is_Statically_Allocated (DT_Ptr,
7203               Is_Library_Level_Tagged_Type (Typ));
7204          end if;
7205
7206       --  Ada types
7207
7208       else
7209          --  Primary dispatch table containing predefined primitives
7210
7211          Predef_Prims_Ptr :=
7212            Make_Defining_Identifier (Loc,
7213              Chars => New_External_Name (Tname, 'Y'));
7214          Set_Etype   (Predef_Prims_Ptr, RTE (RE_Address));
7215          Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
7216
7217          --  Import the forward declaration of the Dispatch Table wrapper
7218          --  record (Make_DT will take care of exporting it).
7219
7220          if Building_Static_DT (Typ) then
7221             Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
7222
7223             DT :=
7224               Make_Defining_Identifier (Loc,
7225                 Chars => New_External_Name (Tname, 'T'));
7226
7227             Import_DT (Typ, DT, Is_Secondary_DT => False);
7228
7229             if Has_DT (Typ) then
7230                Append_To (Result,
7231                  Make_Object_Declaration (Loc,
7232                    Defining_Identifier => DT_Ptr,
7233                    Constant_Present    => True,
7234                    Object_Definition   =>
7235                      New_Occurrence_Of (RTE (RE_Tag), Loc),
7236                    Expression          =>
7237                      Unchecked_Convert_To (RTE (RE_Tag),
7238                        Make_Attribute_Reference (Loc,
7239                          Prefix         =>
7240                            Make_Selected_Component (Loc,
7241                              Prefix        => New_Occurrence_Of (DT, Loc),
7242                              Selector_Name =>
7243                                New_Occurrence_Of
7244                                  (RTE_Record_Component (RE_Prims_Ptr), Loc)),
7245                          Attribute_Name => Name_Address))));
7246
7247                --  Generate the SCIL node for the previous object declaration
7248                --  because it has a tag initialization.
7249
7250                if Generate_SCIL then
7251                   New_Node :=
7252                     Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
7253                   Set_SCIL_Entity (New_Node, Typ);
7254                   Set_SCIL_Node (Last (Result), New_Node);
7255                end if;
7256
7257                Append_To (Result,
7258                  Make_Object_Declaration (Loc,
7259                    Defining_Identifier => Predef_Prims_Ptr,
7260                    Constant_Present    => True,
7261                    Object_Definition   =>
7262                      New_Occurrence_Of (RTE (RE_Address), Loc),
7263                    Expression          =>
7264                      Make_Attribute_Reference (Loc,
7265                        Prefix         =>
7266                          Make_Selected_Component (Loc,
7267                            Prefix        => New_Occurrence_Of (DT, Loc),
7268                            Selector_Name =>
7269                              New_Occurrence_Of
7270                                (RTE_Record_Component (RE_Predef_Prims), Loc)),
7271                        Attribute_Name => Name_Address)));
7272
7273             --  No dispatch table required
7274
7275             else
7276                Append_To (Result,
7277                  Make_Object_Declaration (Loc,
7278                    Defining_Identifier => DT_Ptr,
7279                    Constant_Present    => True,
7280                    Object_Definition   =>
7281                      New_Occurrence_Of (RTE (RE_Tag), Loc),
7282                    Expression          =>
7283                      Unchecked_Convert_To (RTE (RE_Tag),
7284                        Make_Attribute_Reference (Loc,
7285                          Prefix         =>
7286                            Make_Selected_Component (Loc,
7287                              Prefix => New_Occurrence_Of (DT, Loc),
7288                              Selector_Name =>
7289                                New_Occurrence_Of
7290                                  (RTE_Record_Component (RE_NDT_Prims_Ptr),
7291                                   Loc)),
7292                          Attribute_Name => Name_Address))));
7293             end if;
7294
7295             Set_Is_True_Constant (DT_Ptr);
7296             Set_Is_Statically_Allocated (DT_Ptr);
7297          end if;
7298       end if;
7299
7300       --  2) Generate the secondary tag entities
7301
7302       --  Collect the components associated with secondary dispatch tables
7303
7304       if Has_Interfaces (Typ) then
7305          Collect_Interface_Components (Typ, Typ_Comps);
7306
7307          --  For each interface type we build a unique external name associated
7308          --  with its secondary dispatch table. This name is used to declare an
7309          --  object that references this secondary dispatch table, whose value
7310          --  will be used for the elaboration of Typ objects, and also for the
7311          --  elaboration of objects of types derived from Typ that do not
7312          --  override the primitives of this interface type.
7313
7314          Suffix_Index := 1;
7315
7316          --  Note: The value of Suffix_Index must be in sync with the
7317          --  Suffix_Index values of secondary dispatch tables generated
7318          --  by Make_DT.
7319
7320          if Is_CPP_Class (Typ) then
7321             AI_Tag_Comp := First_Elmt (Typ_Comps);
7322             while Present (AI_Tag_Comp) loop
7323                Get_Secondary_DT_External_Name
7324                  (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7325                Typ_Name := Name_Find;
7326
7327                --  Declare variables that will store the copy of the C++
7328                --  secondary tags.
7329
7330                Iface_DT_Ptr :=
7331                  Make_Defining_Identifier (Loc,
7332                    Chars => New_External_Name (Typ_Name, 'P'));
7333                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7334                Set_Ekind (Iface_DT_Ptr, E_Variable);
7335                Set_Is_Tag (Iface_DT_Ptr);
7336
7337                Set_Has_Thunks (Iface_DT_Ptr);
7338                Set_Related_Type
7339                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7340                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7341
7342                Append_To (Result,
7343                  Make_Object_Declaration (Loc,
7344                    Defining_Identifier => Iface_DT_Ptr,
7345                    Object_Definition   => New_Occurrence_Of
7346                                             (RTE (RE_Interface_Tag), Loc),
7347                    Expression =>
7348                      Unchecked_Convert_To (RTE (RE_Interface_Tag),
7349                        New_Occurrence_Of (RTE (RE_Null_Address), Loc))));
7350
7351                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7352                  Is_Library_Level_Tagged_Type (Typ));
7353
7354                Next_Elmt (AI_Tag_Comp);
7355             end loop;
7356
7357          --  This is not a CPP_Class type
7358
7359          else
7360             AI_Tag_Comp := First_Elmt (Typ_Comps);
7361             while Present (AI_Tag_Comp) loop
7362                Get_Secondary_DT_External_Name
7363                  (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
7364                Typ_Name := Name_Find;
7365
7366                if Building_Static_DT (Typ) then
7367                   Iface_DT :=
7368                     Make_Defining_Identifier (Loc,
7369                       Chars => New_External_Name
7370                                  (Typ_Name, 'T', Suffix_Index => -1));
7371                   Import_DT
7372                     (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
7373                      DT      => Iface_DT,
7374                      Is_Secondary_DT => True);
7375                end if;
7376
7377                --  Secondary dispatch table referencing thunks to user-defined
7378                --  primitives covered by this interface.
7379
7380                Iface_DT_Ptr :=
7381                  Make_Defining_Identifier (Loc,
7382                    Chars => New_External_Name (Typ_Name, 'P'));
7383                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7384                Set_Ekind (Iface_DT_Ptr, E_Constant);
7385                Set_Is_Tag (Iface_DT_Ptr);
7386                Set_Has_Thunks (Iface_DT_Ptr);
7387                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7388                  Is_Library_Level_Tagged_Type (Typ));
7389                Set_Is_True_Constant (Iface_DT_Ptr);
7390                Set_Related_Type
7391                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7392                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7393
7394                if Building_Static_DT (Typ) then
7395                   Append_To (Result,
7396                     Make_Object_Declaration (Loc,
7397                       Defining_Identifier => Iface_DT_Ptr,
7398                       Constant_Present    => True,
7399                       Object_Definition   => New_Occurrence_Of
7400                                                (RTE (RE_Interface_Tag), Loc),
7401                       Expression          =>
7402                         Unchecked_Convert_To (RTE (RE_Interface_Tag),
7403                           Make_Attribute_Reference (Loc,
7404                             Prefix         =>
7405                               Make_Selected_Component (Loc,
7406                                 Prefix        =>
7407                                   New_Occurrence_Of (Iface_DT, Loc),
7408                                 Selector_Name =>
7409                                   New_Occurrence_Of
7410                                     (RTE_Record_Component (RE_Prims_Ptr),
7411                                      Loc)),
7412                             Attribute_Name => Name_Address))));
7413                end if;
7414
7415                --  Secondary dispatch table referencing thunks to predefined
7416                --  primitives.
7417
7418                Iface_DT_Ptr :=
7419                  Make_Defining_Identifier (Loc,
7420                    Chars => New_External_Name (Typ_Name, 'Y'));
7421                Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7422                Set_Ekind (Iface_DT_Ptr, E_Constant);
7423                Set_Is_Tag (Iface_DT_Ptr);
7424                Set_Has_Thunks (Iface_DT_Ptr);
7425                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7426                  Is_Library_Level_Tagged_Type (Typ));
7427                Set_Is_True_Constant (Iface_DT_Ptr);
7428                Set_Related_Type
7429                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7430                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7431
7432                --  Secondary dispatch table referencing user-defined primitives
7433                --  covered by this interface.
7434
7435                Iface_DT_Ptr :=
7436                  Make_Defining_Identifier (Loc,
7437                    Chars => New_External_Name (Typ_Name, 'D'));
7438                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
7439                Set_Ekind (Iface_DT_Ptr, E_Constant);
7440                Set_Is_Tag (Iface_DT_Ptr);
7441                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7442                  Is_Library_Level_Tagged_Type (Typ));
7443                Set_Is_True_Constant (Iface_DT_Ptr);
7444                Set_Related_Type
7445                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7446                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7447
7448                --  Secondary dispatch table referencing predefined primitives
7449
7450                Iface_DT_Ptr :=
7451                  Make_Defining_Identifier (Loc,
7452                    Chars => New_External_Name (Typ_Name, 'Z'));
7453                Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
7454                Set_Ekind (Iface_DT_Ptr, E_Constant);
7455                Set_Is_Tag (Iface_DT_Ptr);
7456                Set_Is_Statically_Allocated (Iface_DT_Ptr,
7457                  Is_Library_Level_Tagged_Type (Typ));
7458                Set_Is_True_Constant (Iface_DT_Ptr);
7459                Set_Related_Type
7460                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
7461                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
7462
7463                Next_Elmt (AI_Tag_Comp);
7464             end loop;
7465          end if;
7466       end if;
7467
7468       --  3) At the end of Access_Disp_Table, if the type has user-defined
7469       --     primitives, we add the entity of an access type declaration that
7470       --     is used by Build_Get_Prim_Op_Address to expand dispatching calls
7471       --     through the primary dispatch table.
7472
7473       if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
7474          Analyze_List (Result);
7475
7476       --     Generate:
7477       --       type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
7478       --       type Typ_DT_Acc is access Typ_DT;
7479
7480       else
7481          declare
7482             Name_DT_Prims     : constant Name_Id :=
7483                                   New_External_Name (Tname, 'G');
7484             Name_DT_Prims_Acc : constant Name_Id :=
7485                                   New_External_Name (Tname, 'H');
7486             DT_Prims          : constant Entity_Id :=
7487                                   Make_Defining_Identifier (Loc,
7488                                     Name_DT_Prims);
7489             DT_Prims_Acc      : constant Entity_Id :=
7490                                   Make_Defining_Identifier (Loc,
7491                                     Name_DT_Prims_Acc);
7492          begin
7493             Append_To (Result,
7494               Make_Full_Type_Declaration (Loc,
7495                 Defining_Identifier => DT_Prims,
7496                 Type_Definition =>
7497                   Make_Constrained_Array_Definition (Loc,
7498                     Discrete_Subtype_Definitions => New_List (
7499                       Make_Range (Loc,
7500                         Low_Bound  => Make_Integer_Literal (Loc, 1),
7501                         High_Bound => Make_Integer_Literal (Loc,
7502                                        DT_Entry_Count
7503                                          (First_Tag_Component (Typ))))),
7504                     Component_Definition =>
7505                       Make_Component_Definition (Loc,
7506                         Subtype_Indication =>
7507                           New_Occurrence_Of (RTE (RE_Prim_Ptr), Loc)))));
7508
7509             Append_To (Result,
7510               Make_Full_Type_Declaration (Loc,
7511                 Defining_Identifier => DT_Prims_Acc,
7512                 Type_Definition =>
7513                    Make_Access_To_Object_Definition (Loc,
7514                      Subtype_Indication =>
7515                        New_Occurrence_Of (DT_Prims, Loc))));
7516
7517             Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
7518
7519             --  Analyze the resulting list and suppress the generation of the
7520             --  Init_Proc associated with the above array declaration because
7521             --  this type is never used in object declarations. It is only used
7522             --  to simplify the expansion associated with dispatching calls.
7523
7524             Analyze_List (Result);
7525             Set_Suppress_Initialization (Base_Type (DT_Prims));
7526
7527             --  Disable backend optimizations based on assumptions about the
7528             --  aliasing status of objects designated by the access to the
7529             --  dispatch table. Required to handle dispatch tables imported
7530             --  from C++.
7531
7532             Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
7533
7534             --  Add the freezing nodes of these declarations; required to avoid
7535             --  generating these freezing nodes in wrong scopes (for example in
7536             --  the IC routine of a derivation of Typ).
7537             --  What is an "IC routine"? Is "init_proc" meant here???
7538
7539             Append_List_To (Result, Freeze_Entity (DT_Prims, Typ));
7540             Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ));
7541
7542             --  Mark entity of dispatch table. Required by the back end to
7543             --  handle them properly.
7544
7545             Set_Is_Dispatch_Table_Entity (DT_Prims);
7546          end;
7547       end if;
7548
7549       --  Mark entities of dispatch table. Required by the back end to handle
7550       --  them properly.
7551
7552       if Present (DT) then
7553          Set_Is_Dispatch_Table_Entity (DT);
7554          Set_Is_Dispatch_Table_Entity (Etype (DT));
7555       end if;
7556
7557       if Present (Iface_DT) then
7558          Set_Is_Dispatch_Table_Entity (Iface_DT);
7559          Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
7560       end if;
7561
7562       if Is_CPP_Class (Root_Type (Typ)) then
7563          Set_Ekind (DT_Ptr, E_Variable);
7564       else
7565          Set_Ekind (DT_Ptr, E_Constant);
7566       end if;
7567
7568       Set_Is_Tag       (DT_Ptr);
7569       Set_Related_Type (DT_Ptr, Typ);
7570
7571       return Result;
7572    end Make_Tags;
7573
7574    ---------------
7575    -- New_Value --
7576    ---------------
7577
7578    function New_Value (From : Node_Id) return Node_Id is
7579       Res : constant Node_Id := Duplicate_Subexpr (From);
7580    begin
7581       if Is_Access_Type (Etype (From)) then
7582          return
7583            Make_Explicit_Dereference (Sloc (From),
7584              Prefix => Res);
7585       else
7586          return Res;
7587       end if;
7588    end New_Value;
7589
7590    -----------------------------------
7591    -- Original_View_In_Visible_Part --
7592    -----------------------------------
7593
7594    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
7595       Scop : constant Entity_Id := Scope (Typ);
7596
7597    begin
7598       --  The scope must be a package
7599
7600       if not Is_Package_Or_Generic_Package (Scop) then
7601          return False;
7602       end if;
7603
7604       --  A type with a private declaration has a private view declared in
7605       --  the visible part.
7606
7607       if Has_Private_Declaration (Typ) then
7608          return True;
7609       end if;
7610
7611       return List_Containing (Parent (Typ)) =
7612         Visible_Declarations (Package_Specification (Scop));
7613    end Original_View_In_Visible_Part;
7614
7615    ------------------
7616    -- Prim_Op_Kind --
7617    ------------------
7618
7619    function Prim_Op_Kind
7620      (Prim : Entity_Id;
7621       Typ  : Entity_Id) return Node_Id
7622    is
7623       Full_Typ : Entity_Id := Typ;
7624       Loc      : constant Source_Ptr := Sloc (Prim);
7625       Prim_Op  : Entity_Id;
7626
7627    begin
7628       --  Retrieve the original primitive operation
7629
7630       Prim_Op := Ultimate_Alias (Prim);
7631
7632       if Ekind (Typ) = E_Record_Type
7633         and then Present (Corresponding_Concurrent_Type (Typ))
7634       then
7635          Full_Typ := Corresponding_Concurrent_Type (Typ);
7636       end if;
7637
7638       --  When a private tagged type is completed by a concurrent type,
7639       --  retrieve the full view.
7640
7641       if Is_Private_Type (Full_Typ) then
7642          Full_Typ := Full_View (Full_Typ);
7643       end if;
7644
7645       if Ekind (Prim_Op) = E_Function then
7646
7647          --  Protected function
7648
7649          if Ekind (Full_Typ) = E_Protected_Type then
7650             return New_Occurrence_Of (RTE (RE_POK_Protected_Function), Loc);
7651
7652          --  Task function
7653
7654          elsif Ekind (Full_Typ) = E_Task_Type then
7655             return New_Occurrence_Of (RTE (RE_POK_Task_Function), Loc);
7656
7657          --  Regular function
7658
7659          else
7660             return New_Occurrence_Of (RTE (RE_POK_Function), Loc);
7661          end if;
7662
7663       else
7664          pragma Assert (Ekind (Prim_Op) = E_Procedure);
7665
7666          if Ekind (Full_Typ) = E_Protected_Type then
7667
7668             --  Protected entry
7669
7670             if Is_Primitive_Wrapper (Prim_Op)
7671               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7672             then
7673                return New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc);
7674
7675             --  Protected procedure
7676
7677             else
7678                return
7679                  New_Occurrence_Of (RTE (RE_POK_Protected_Procedure), Loc);
7680             end if;
7681
7682          elsif Ekind (Full_Typ) = E_Task_Type then
7683
7684             --  Task entry
7685
7686             if Is_Primitive_Wrapper (Prim_Op)
7687               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
7688             then
7689                return New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc);
7690
7691             --  Task "procedure". These are the internally Expander-generated
7692             --  procedures (task body for instance).
7693
7694             else
7695                return New_Occurrence_Of (RTE (RE_POK_Task_Procedure), Loc);
7696             end if;
7697
7698          --  Regular procedure
7699
7700          else
7701             return New_Occurrence_Of (RTE (RE_POK_Procedure), Loc);
7702          end if;
7703       end if;
7704    end Prim_Op_Kind;
7705
7706    ------------------------
7707    -- Register_Primitive --
7708    ------------------------
7709
7710    function Register_Primitive
7711      (Loc     : Source_Ptr;
7712       Prim    : Entity_Id) return List_Id
7713    is
7714       DT_Ptr        : Entity_Id;
7715       Iface_Prim    : Entity_Id;
7716       Iface_Typ     : Entity_Id;
7717       Iface_DT_Ptr  : Entity_Id;
7718       Iface_DT_Elmt : Elmt_Id;
7719       L             : constant List_Id := New_List;
7720       Pos           : Uint;
7721       Tag           : Entity_Id;
7722       Tag_Typ       : Entity_Id;
7723       Thunk_Id      : Entity_Id;
7724       Thunk_Code    : Node_Id;
7725
7726    begin
7727       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
7728       pragma Assert (VM_Target = No_VM);
7729
7730       --  Do not register in the dispatch table eliminated primitives
7731
7732       if not RTE_Available (RE_Tag)
7733         or else Is_Eliminated (Ultimate_Alias (Prim))
7734       then
7735          return L;
7736       end if;
7737
7738       if not Present (Interface_Alias (Prim)) then
7739          Tag_Typ := Scope (DTC_Entity (Prim));
7740          Pos := DT_Position (Prim);
7741          Tag := First_Tag_Component (Tag_Typ);
7742
7743          if Is_Predefined_Dispatching_Operation (Prim)
7744            or else Is_Predefined_Dispatching_Alias (Prim)
7745          then
7746             DT_Ptr :=
7747               Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
7748
7749             Append_To (L,
7750               Build_Set_Predefined_Prim_Op_Address (Loc,
7751                 Tag_Node     => New_Occurrence_Of (DT_Ptr, Loc),
7752                 Position     => Pos,
7753                 Address_Node =>
7754                   Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7755                     Make_Attribute_Reference (Loc,
7756                       Prefix         => New_Occurrence_Of (Prim, Loc),
7757                       Attribute_Name => Name_Unrestricted_Access))));
7758
7759             --  Register copy of the pointer to the 'size primitive in the TSD
7760
7761             if Chars (Prim) = Name_uSize
7762               and then RTE_Record_Component_Available (RE_Size_Func)
7763             then
7764                DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7765                Append_To (L,
7766                  Build_Set_Size_Function (Loc,
7767                    Tag_Node  => New_Occurrence_Of (DT_Ptr, Loc),
7768                    Size_Func => Prim));
7769             end if;
7770
7771          else
7772             pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
7773
7774             --  Skip registration of primitives located in the C++ part of the
7775             --  dispatch table. Their slot is set by the IC routine.
7776
7777             if not Is_CPP_Class (Root_Type (Tag_Typ))
7778               or else Pos > CPP_Num_Prims (Tag_Typ)
7779             then
7780                DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
7781                Append_To (L,
7782                  Build_Set_Prim_Op_Address (Loc,
7783                    Typ          => Tag_Typ,
7784                    Tag_Node     => New_Occurrence_Of (DT_Ptr, Loc),
7785                    Position     => Pos,
7786                    Address_Node =>
7787                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7788                        Make_Attribute_Reference (Loc,
7789                          Prefix         => New_Occurrence_Of (Prim, Loc),
7790                          Attribute_Name => Name_Unrestricted_Access))));
7791             end if;
7792          end if;
7793
7794       --  Ada 2005 (AI-251): Primitive associated with an interface type
7795       --  Generate the code of the thunk only if the interface type is not an
7796       --  immediate ancestor of Typ; otherwise the dispatch table associated
7797       --  with the interface is the primary dispatch table and we have nothing
7798       --  else to do here.
7799
7800       else
7801          Tag_Typ   := Find_Dispatching_Type (Alias (Prim));
7802          Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
7803
7804          pragma Assert (Is_Interface (Iface_Typ));
7805
7806          --  No action needed for interfaces that are ancestors of Typ because
7807          --  their primitives are located in the primary dispatch table.
7808
7809          if Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) then
7810             return L;
7811
7812          --  No action needed for primitives located in the C++ part of the
7813          --  dispatch table. Their slot is set by the IC routine.
7814
7815          elsif Is_CPP_Class (Root_Type (Tag_Typ))
7816             and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
7817             and then not Is_Predefined_Dispatching_Operation (Prim)
7818             and then not Is_Predefined_Dispatching_Alias (Prim)
7819          then
7820             return L;
7821          end if;
7822
7823          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
7824
7825          if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
7826            and then Present (Thunk_Code)
7827          then
7828             --  Generate the code necessary to fill the appropriate entry of
7829             --  the secondary dispatch table of Prim's controlling type with
7830             --  Thunk_Id's address.
7831
7832             Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
7833             Iface_DT_Ptr  := Node (Iface_DT_Elmt);
7834             pragma Assert (Has_Thunks (Iface_DT_Ptr));
7835
7836             Iface_Prim := Interface_Alias (Prim);
7837             Pos        := DT_Position (Iface_Prim);
7838             Tag        := First_Tag_Component (Iface_Typ);
7839
7840             Prepend_To (L, Thunk_Code);
7841
7842             if Is_Predefined_Dispatching_Operation (Prim)
7843               or else Is_Predefined_Dispatching_Alias (Prim)
7844             then
7845                Append_To (L,
7846                  Build_Set_Predefined_Prim_Op_Address (Loc,
7847                    Tag_Node =>
7848                      New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7849                    Position => Pos,
7850                    Address_Node =>
7851                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7852                        Make_Attribute_Reference (Loc,
7853                          Prefix          => New_Occurrence_Of (Thunk_Id, Loc),
7854                          Attribute_Name  => Name_Unrestricted_Access))));
7855
7856                Next_Elmt (Iface_DT_Elmt);
7857                Next_Elmt (Iface_DT_Elmt);
7858                Iface_DT_Ptr := Node (Iface_DT_Elmt);
7859                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7860
7861                Append_To (L,
7862                  Build_Set_Predefined_Prim_Op_Address (Loc,
7863                    Tag_Node =>
7864                      New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7865                    Position => Pos,
7866                    Address_Node =>
7867                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7868                        Make_Attribute_Reference (Loc,
7869                          Prefix          =>
7870                            New_Occurrence_Of (Alias (Prim), Loc),
7871                          Attribute_Name  => Name_Unrestricted_Access))));
7872
7873             else
7874                pragma Assert (Pos /= Uint_0
7875                  and then Pos <= DT_Entry_Count (Tag));
7876
7877                Append_To (L,
7878                  Build_Set_Prim_Op_Address (Loc,
7879                    Typ          => Iface_Typ,
7880                    Tag_Node     => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7881                    Position     => Pos,
7882                    Address_Node =>
7883                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7884                        Make_Attribute_Reference (Loc,
7885                          Prefix => New_Occurrence_Of (Thunk_Id, Loc),
7886                          Attribute_Name => Name_Unrestricted_Access))));
7887
7888                Next_Elmt (Iface_DT_Elmt);
7889                Next_Elmt (Iface_DT_Elmt);
7890                Iface_DT_Ptr := Node (Iface_DT_Elmt);
7891                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7892
7893                Append_To (L,
7894                  Build_Set_Prim_Op_Address (Loc,
7895                    Typ          => Iface_Typ,
7896                    Tag_Node     => New_Occurrence_Of (Iface_DT_Ptr, Loc),
7897                    Position     => Pos,
7898                    Address_Node =>
7899                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7900                        Make_Attribute_Reference (Loc,
7901                          Prefix         =>
7902                            New_Occurrence_Of (Alias (Prim), Loc),
7903                          Attribute_Name => Name_Unrestricted_Access))));
7904
7905             end if;
7906          end if;
7907       end if;
7908
7909       return L;
7910    end Register_Primitive;
7911
7912    -------------------------
7913    -- Set_All_DT_Position --
7914    -------------------------
7915
7916    procedure Set_All_DT_Position (Typ : Entity_Id) is
7917
7918       function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean;
7919       --  Returns True if Prim is located in the dispatch table of
7920       --  predefined primitives
7921
7922       procedure Validate_Position (Prim : Entity_Id);
7923       --  Check that the position assigned to Prim is completely safe
7924       --  (it has not been assigned to a previously defined primitive
7925       --   operation of Typ)
7926
7927       ------------------------
7928       -- In_Predef_Prims_DT --
7929       ------------------------
7930
7931       function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
7932          E : Entity_Id;
7933
7934       begin
7935          --  Predefined primitives
7936
7937          if Is_Predefined_Dispatching_Operation (Prim) then
7938             return True;
7939
7940          --  Renamings of predefined primitives
7941
7942          elsif Present (Alias (Prim))
7943            and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim))
7944          then
7945             if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
7946                return True;
7947
7948             --  User-defined renamings of predefined equality have their own
7949             --  slot in the primary dispatch table
7950
7951             else
7952                E := Prim;
7953                while Present (Alias (E)) loop
7954                   if Comes_From_Source (E) then
7955                      return False;
7956                   end if;
7957
7958                   E := Alias (E);
7959                end loop;
7960
7961                return not Comes_From_Source (E);
7962             end if;
7963
7964          --  User-defined primitives
7965
7966          else
7967             return False;
7968          end if;
7969       end In_Predef_Prims_DT;
7970
7971       -----------------------
7972       -- Validate_Position --
7973       -----------------------
7974
7975       procedure Validate_Position (Prim : Entity_Id) is
7976          Op_Elmt : Elmt_Id;
7977          Op      : Entity_Id;
7978
7979       begin
7980          --  Aliased primitives are safe
7981
7982          if Present (Alias (Prim)) then
7983             return;
7984          end if;
7985
7986          Op_Elmt := First_Elmt (Primitive_Operations (Typ));
7987          while Present (Op_Elmt) loop
7988             Op := Node (Op_Elmt);
7989
7990             --  No need to check against itself
7991
7992             if Op = Prim then
7993                null;
7994
7995             --  Primitive operations covering abstract interfaces are
7996             --  allocated later
7997
7998             elsif Present (Interface_Alias (Op)) then
7999                null;
8000
8001             --  Predefined dispatching operations are completely safe. They
8002             --  are allocated at fixed positions in a separate table.
8003
8004             elsif Is_Predefined_Dispatching_Operation (Op)
8005                or else Is_Predefined_Dispatching_Alias (Op)
8006             then
8007                null;
8008
8009             --  Aliased subprograms are safe
8010
8011             elsif Present (Alias (Op)) then
8012                null;
8013
8014             elsif DT_Position (Op) = DT_Position (Prim)
8015                and then not Is_Predefined_Dispatching_Operation (Op)
8016                and then not Is_Predefined_Dispatching_Operation (Prim)
8017                and then not Is_Predefined_Dispatching_Alias (Op)
8018                and then not Is_Predefined_Dispatching_Alias (Prim)
8019             then
8020
8021                --  Handle aliased subprograms
8022
8023                declare
8024                   Op_1 : Entity_Id;
8025                   Op_2 : Entity_Id;
8026
8027                begin
8028                   Op_1 := Op;
8029                   loop
8030                      if Present (Overridden_Operation (Op_1)) then
8031                         Op_1 := Overridden_Operation (Op_1);
8032                      elsif Present (Alias (Op_1)) then
8033                         Op_1 := Alias (Op_1);
8034                      else
8035                         exit;
8036                      end if;
8037                   end loop;
8038
8039                   Op_2 := Prim;
8040                   loop
8041                      if Present (Overridden_Operation (Op_2)) then
8042                         Op_2 := Overridden_Operation (Op_2);
8043                      elsif Present (Alias (Op_2)) then
8044                         Op_2 := Alias (Op_2);
8045                      else
8046                         exit;
8047                      end if;
8048                   end loop;
8049
8050                   if Op_1 /= Op_2 then
8051                      raise Program_Error;
8052                   end if;
8053                end;
8054             end if;
8055
8056             Next_Elmt (Op_Elmt);
8057          end loop;
8058       end Validate_Position;
8059
8060       --  Local variables
8061
8062       Parent_Typ : constant Entity_Id := Etype (Typ);
8063       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
8064       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
8065
8066       Adjusted  : Boolean := False;
8067       Finalized : Boolean := False;
8068
8069       Count_Prim : Nat;
8070       DT_Length  : Nat;
8071       Nb_Prim    : Nat;
8072       Prim       : Entity_Id;
8073       Prim_Elmt  : Elmt_Id;
8074
8075    --  Start of processing for Set_All_DT_Position
8076
8077    begin
8078       pragma Assert (Present (First_Tag_Component (Typ)));
8079
8080       --  Set the DT_Position for each primitive operation. Perform some sanity
8081       --  checks to avoid building inconsistent dispatch tables.
8082
8083       --  First stage: Set the DTC entity of all the primitive operations. This
8084       --  is required to properly read the DT_Position attribute in the latter
8085       --  stages.
8086
8087       Prim_Elmt  := First_Prim;
8088       Count_Prim := 0;
8089       while Present (Prim_Elmt) loop
8090          Prim := Node (Prim_Elmt);
8091
8092          --  Predefined primitives have a separate dispatch table
8093
8094          if not In_Predef_Prims_DT (Prim) then
8095             Count_Prim := Count_Prim + 1;
8096          end if;
8097
8098          Set_DTC_Entity_Value (Typ, Prim);
8099
8100          --  Clear any previous value of the DT_Position attribute. In this
8101          --  way we ensure that the final position of all the primitives is
8102          --  established by the following stages of this algorithm.
8103
8104          Set_DT_Position (Prim, No_Uint);
8105
8106          Next_Elmt (Prim_Elmt);
8107       end loop;
8108
8109       declare
8110          Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
8111                         (others => False);
8112
8113          E : Entity_Id;
8114
8115          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
8116          --  Called if Typ is declared in a nested package or a public child
8117          --  package to handle inherited primitives that were inherited by Typ
8118          --  in the visible part, but whose declaration was deferred because
8119          --  the parent operation was private and not visible at that point.
8120
8121          procedure Set_Fixed_Prim (Pos : Nat);
8122          --  Sets to true an element of the Fixed_Prim table to indicate
8123          --  that this entry of the dispatch table of Typ is occupied.
8124
8125          ------------------------------------------
8126          -- Handle_Inherited_Private_Subprograms --
8127          ------------------------------------------
8128
8129          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
8130             Op_List     : Elist_Id;
8131             Op_Elmt     : Elmt_Id;
8132             Op_Elmt_2   : Elmt_Id;
8133             Prim_Op     : Entity_Id;
8134             Parent_Subp : Entity_Id;
8135
8136          begin
8137             Op_List := Primitive_Operations (Typ);
8138
8139             Op_Elmt := First_Elmt (Op_List);
8140             while Present (Op_Elmt) loop
8141                Prim_Op := Node (Op_Elmt);
8142
8143                --  Search primitives that are implicit operations with an
8144                --  internal name whose parent operation has a normal name.
8145
8146                if Present (Alias (Prim_Op))
8147                  and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
8148                  and then not Comes_From_Source (Prim_Op)
8149                  and then Is_Internal_Name (Chars (Prim_Op))
8150                  and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
8151                then
8152                   Parent_Subp := Alias (Prim_Op);
8153
8154                   --  Check if the type has an explicit overriding for this
8155                   --  primitive.
8156
8157                   Op_Elmt_2 := Next_Elmt (Op_Elmt);
8158                   while Present (Op_Elmt_2) loop
8159                      if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
8160                        and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
8161                      then
8162                         Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
8163                         Set_DT_Position (Node (Op_Elmt_2),
8164                           DT_Position (Parent_Subp));
8165                         Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
8166
8167                         goto Next_Primitive;
8168                      end if;
8169
8170                      Next_Elmt (Op_Elmt_2);
8171                   end loop;
8172                end if;
8173
8174                <<Next_Primitive>>
8175                Next_Elmt (Op_Elmt);
8176             end loop;
8177          end Handle_Inherited_Private_Subprograms;
8178
8179          --------------------
8180          -- Set_Fixed_Prim --
8181          --------------------
8182
8183          procedure Set_Fixed_Prim (Pos : Nat) is
8184          begin
8185             pragma Assert (Pos <= Count_Prim);
8186             Fixed_Prim (Pos) := True;
8187          exception
8188             when Constraint_Error =>
8189                raise Program_Error;
8190          end Set_Fixed_Prim;
8191
8192       begin
8193          --  In case of nested packages and public child package it may be
8194          --  necessary a special management on inherited subprograms so that
8195          --  the dispatch table is properly filled.
8196
8197          if Ekind (Scope (Scope (Typ))) = E_Package
8198            and then Scope (Scope (Typ)) /= Standard_Standard
8199            and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
8200                        or else
8201                         (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
8202                           and then Is_Generic_Type (Typ)))
8203            and then In_Open_Scopes (Scope (Etype (Typ)))
8204            and then Is_Base_Type (Typ)
8205          then
8206             Handle_Inherited_Private_Subprograms (Typ);
8207          end if;
8208
8209          --  Second stage: Register fixed entries
8210
8211          Nb_Prim   := 0;
8212          Prim_Elmt := First_Prim;
8213          while Present (Prim_Elmt) loop
8214             Prim := Node (Prim_Elmt);
8215
8216             --  Predefined primitives have a separate table and all its
8217             --  entries are at predefined fixed positions.
8218
8219             if In_Predef_Prims_DT (Prim) then
8220                if Is_Predefined_Dispatching_Operation (Prim) then
8221                   Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
8222
8223                else pragma Assert (Present (Alias (Prim)));
8224                   Set_DT_Position (Prim,
8225                     Default_Prim_Op_Position (Ultimate_Alias (Prim)));
8226                end if;
8227
8228             --  Overriding primitives of ancestor abstract interfaces
8229
8230             elsif Present (Interface_Alias (Prim))
8231               and then Is_Ancestor
8232                          (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
8233                           Use_Full_View => True)
8234             then
8235                pragma Assert (DT_Position (Prim) = No_Uint
8236                  and then Present (DTC_Entity (Interface_Alias (Prim))));
8237
8238                E := Interface_Alias (Prim);
8239                Set_DT_Position (Prim, DT_Position (E));
8240
8241                pragma Assert
8242                  (DT_Position (Alias (Prim)) = No_Uint
8243                     or else DT_Position (Alias (Prim)) = DT_Position (E));
8244                Set_DT_Position (Alias (Prim), DT_Position (E));
8245                Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
8246
8247             --  Overriding primitives must use the same entry as the
8248             --  overridden primitive.
8249
8250             elsif not Present (Interface_Alias (Prim))
8251               and then Present (Alias (Prim))
8252               and then Chars (Prim) = Chars (Alias (Prim))
8253               and then Find_Dispatching_Type (Alias (Prim)) /= Typ
8254               and then Is_Ancestor
8255                          (Find_Dispatching_Type (Alias (Prim)), Typ,
8256                           Use_Full_View => True)
8257               and then Present (DTC_Entity (Alias (Prim)))
8258             then
8259                E := Alias (Prim);
8260                Set_DT_Position (Prim, DT_Position (E));
8261
8262                if not Is_Predefined_Dispatching_Alias (E) then
8263                   Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
8264                end if;
8265             end if;
8266
8267             Next_Elmt (Prim_Elmt);
8268          end loop;
8269
8270          --  Third stage: Fix the position of all the new primitives.
8271          --  Entries associated with primitives covering interfaces
8272          --  are handled in a latter round.
8273
8274          Prim_Elmt := First_Prim;
8275          while Present (Prim_Elmt) loop
8276             Prim := Node (Prim_Elmt);
8277
8278             --  Skip primitives previously set entries
8279
8280             if DT_Position (Prim) /= No_Uint then
8281                null;
8282
8283             --  Primitives covering interface primitives are handled later
8284
8285             elsif Present (Interface_Alias (Prim)) then
8286                null;
8287
8288             else
8289                --  Take the next available position in the DT
8290
8291                loop
8292                   Nb_Prim := Nb_Prim + 1;
8293                   pragma Assert (Nb_Prim <= Count_Prim);
8294                   exit when not Fixed_Prim (Nb_Prim);
8295                end loop;
8296
8297                Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
8298                Set_Fixed_Prim (Nb_Prim);
8299             end if;
8300
8301             Next_Elmt (Prim_Elmt);
8302          end loop;
8303       end;
8304
8305       --  Fourth stage: Complete the decoration of primitives covering
8306       --  interfaces (that is, propagate the DT_Position attribute
8307       --  from the aliased primitive)
8308
8309       Prim_Elmt := First_Prim;
8310       while Present (Prim_Elmt) loop
8311          Prim := Node (Prim_Elmt);
8312
8313          if DT_Position (Prim) = No_Uint
8314            and then Present (Interface_Alias (Prim))
8315          then
8316             pragma Assert (Present (Alias (Prim))
8317               and then Find_Dispatching_Type (Alias (Prim)) = Typ);
8318
8319             --  Check if this entry will be placed in the primary DT
8320
8321             if Is_Ancestor
8322                  (Find_Dispatching_Type (Interface_Alias (Prim)), Typ,
8323                   Use_Full_View => True)
8324             then
8325                pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
8326                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
8327
8328             --  Otherwise it will be placed in the secondary DT
8329
8330             else
8331                pragma Assert
8332                  (DT_Position (Interface_Alias (Prim)) /= No_Uint);
8333                Set_DT_Position (Prim,
8334                  DT_Position (Interface_Alias (Prim)));
8335             end if;
8336          end if;
8337
8338          Next_Elmt (Prim_Elmt);
8339       end loop;
8340
8341       --  Generate listing showing the contents of the dispatch tables.
8342       --  This action is done before some further static checks because
8343       --  in case of critical errors caused by a wrong dispatch table
8344       --  we need to see the contents of such table.
8345
8346       if Debug_Flag_ZZ then
8347          Write_DT (Typ);
8348       end if;
8349
8350       --  Final stage: Ensure that the table is correct plus some further
8351       --  verifications concerning the primitives.
8352
8353       Prim_Elmt := First_Prim;
8354       DT_Length := 0;
8355       while Present (Prim_Elmt) loop
8356          Prim := Node (Prim_Elmt);
8357
8358          --  At this point all the primitives MUST have a position
8359          --  in the dispatch table.
8360
8361          if DT_Position (Prim) = No_Uint then
8362             raise Program_Error;
8363          end if;
8364
8365          --  Calculate real size of the dispatch table
8366
8367          if not In_Predef_Prims_DT (Prim)
8368            and then UI_To_Int (DT_Position (Prim)) > DT_Length
8369          then
8370             DT_Length := UI_To_Int (DT_Position (Prim));
8371          end if;
8372
8373          --  Ensure that the assigned position to non-predefined
8374          --  dispatching operations in the dispatch table is correct.
8375
8376          if not Is_Predefined_Dispatching_Operation (Prim)
8377            and then not Is_Predefined_Dispatching_Alias (Prim)
8378          then
8379             Validate_Position (Prim);
8380          end if;
8381
8382          if Chars (Prim) = Name_Finalize then
8383             Finalized := True;
8384          end if;
8385
8386          if Chars (Prim) = Name_Adjust then
8387             Adjusted := True;
8388          end if;
8389
8390          --  An abstract operation cannot be declared in the private part for a
8391          --  visible abstract type, because it can't be overridden outside this
8392          --  package hierarchy. For explicit declarations this is checked at
8393          --  the point of declaration, but for inherited operations it must be
8394          --  done when building the dispatch table.
8395
8396          --  Ada 2005 (AI-251): Primitives associated with interfaces are
8397          --  excluded from this check because interfaces must be visible in
8398          --  the public and private part (RM 7.3 (7.3/2))
8399
8400          --  We disable this check in Relaxed_RM_Semantics mode, to
8401          --  accommodate legacy Ada code.
8402
8403          if not Relaxed_RM_Semantics
8404            and then Is_Abstract_Type (Typ)
8405            and then Is_Abstract_Subprogram (Prim)
8406            and then Present (Alias (Prim))
8407            and then not Is_Interface
8408                           (Find_Dispatching_Type (Ultimate_Alias (Prim)))
8409            and then not Present (Interface_Alias (Prim))
8410            and then Is_Derived_Type (Typ)
8411            and then In_Private_Part (Current_Scope)
8412            and then
8413              List_Containing (Parent (Prim)) =
8414                Private_Declarations (Package_Specification (Current_Scope))
8415            and then Original_View_In_Visible_Part (Typ)
8416          then
8417             --  We exclude Input and Output stream operations because
8418             --  Limited_Controlled inherits useless Input and Output
8419             --  stream operations from Root_Controlled, which can
8420             --  never be overridden.
8421
8422             if not Is_TSS (Prim, TSS_Stream_Input)
8423                  and then
8424                not Is_TSS (Prim, TSS_Stream_Output)
8425             then
8426                Error_Msg_NE
8427                  ("abstract inherited private operation&" &
8428                   " must be overridden (RM 3.9.3(10))",
8429                  Parent (Typ), Prim);
8430             end if;
8431          end if;
8432
8433          Next_Elmt (Prim_Elmt);
8434       end loop;
8435
8436       --  Additional check
8437
8438       if Is_Controlled (Typ) then
8439          if not Finalized then
8440             Error_Msg_N
8441               ("controlled type has no explicit Finalize method??", Typ);
8442
8443          elsif not Adjusted then
8444             Error_Msg_N
8445               ("controlled type has no explicit Adjust method??", Typ);
8446          end if;
8447       end if;
8448
8449       --  Set the final size of the Dispatch Table
8450
8451       Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
8452
8453       --  The derived type must have at least as many components as its parent
8454       --  (for root types Etype points to itself and the test cannot fail).
8455
8456       if DT_Entry_Count (The_Tag) <
8457            DT_Entry_Count (First_Tag_Component (Parent_Typ))
8458       then
8459          raise Program_Error;
8460       end if;
8461    end Set_All_DT_Position;
8462
8463    --------------------------
8464    -- Set_CPP_Constructors --
8465    --------------------------
8466
8467    procedure Set_CPP_Constructors (Typ : Entity_Id) is
8468
8469       function Gen_Parameters_Profile (E : Entity_Id) return List_Id;
8470       --  Duplicate the parameters profile of the imported C++ constructor
8471       --  adding an access to the object as an additional parameter.
8472
8473       function Gen_Parameters_Profile (E : Entity_Id) return List_Id is
8474          Loc   : constant Source_Ptr := Sloc (E);
8475          Parms : List_Id;
8476          P     : Node_Id;
8477
8478       begin
8479          Parms :=
8480            New_List (
8481              Make_Parameter_Specification (Loc,
8482                Defining_Identifier =>
8483                  Make_Defining_Identifier (Loc, Name_uInit),
8484                Parameter_Type      => New_Occurrence_Of (Typ, Loc)));
8485
8486          if Present (Parameter_Specifications (Parent (E))) then
8487             P := First (Parameter_Specifications (Parent (E)));
8488             while Present (P) loop
8489                Append_To (Parms,
8490                  Make_Parameter_Specification (Loc,
8491                    Defining_Identifier =>
8492                      Make_Defining_Identifier (Loc,
8493                        Chars => Chars (Defining_Identifier (P))),
8494                    Parameter_Type      => New_Copy_Tree (Parameter_Type (P)),
8495                    Expression          => New_Copy_Tree (Expression (P))));
8496                Next (P);
8497             end loop;
8498          end if;
8499
8500          return Parms;
8501       end Gen_Parameters_Profile;
8502
8503       --  Local variables
8504
8505       Loc     : Source_Ptr;
8506       E       : Entity_Id;
8507       Found   : Boolean := False;
8508       IP      : Entity_Id;
8509       IP_Body : Node_Id;
8510       P       : Node_Id;
8511       Parms   : List_Id;
8512
8513       Covers_Default_Constructor : Entity_Id := Empty;
8514
8515    --  Start of processing for Set_CPP_Constructor
8516
8517    begin
8518       pragma Assert (Is_CPP_Class (Typ));
8519
8520       --  Look for the constructor entities
8521
8522       E := Next_Entity (Typ);
8523       while Present (E) loop
8524          if Ekind (E) = E_Function
8525            and then Is_Constructor (E)
8526          then
8527             Found := True;
8528             Loc   := Sloc (E);
8529             Parms := Gen_Parameters_Profile (E);
8530             IP    :=
8531               Make_Defining_Identifier (Loc,
8532                 Chars => Make_Init_Proc_Name (Typ));
8533
8534             --  Case 1: Constructor of non-tagged type
8535
8536             --  If the C++ class has no virtual methods then the matching Ada
8537             --  type is a non-tagged record type. In such case there is no need
8538             --  to generate a wrapper of the C++ constructor because the _tag
8539             --  component is not available.
8540
8541             if not Is_Tagged_Type (Typ) then
8542                Discard_Node
8543                  (Make_Subprogram_Declaration (Loc,
8544                     Specification =>
8545                       Make_Procedure_Specification (Loc,
8546                         Defining_Unit_Name       => IP,
8547                         Parameter_Specifications => Parms)));
8548
8549                Set_Init_Proc (Typ, IP);
8550                Set_Is_Imported    (IP);
8551                Set_Is_Constructor (IP);
8552                Set_Interface_Name (IP, Interface_Name (E));
8553                Set_Convention     (IP, Convention_CPP);
8554                Set_Is_Public      (IP);
8555                Set_Has_Completion (IP);
8556
8557             --  Case 2: Constructor of a tagged type
8558
8559             --  In this case we generate the IP as a wrapper of the the
8560             --  C++ constructor because IP must also save copy of the _tag
8561             --  generated in the C++ side. The copy of the _tag is used by
8562             --  Build_CPP_Init_Procedure to elaborate derivations of C++ types.
8563
8564             --  Generate:
8565             --     procedure IP (_init : Typ; ...) is
8566             --        procedure ConstructorP (_init : Typ; ...);
8567             --        pragma Import (ConstructorP);
8568             --     begin
8569             --        ConstructorP (_init, ...);
8570             --        if Typ._tag = null then
8571             --           Typ._tag := _init._tag;
8572             --        end if;
8573             --     end IP;
8574
8575             else
8576                declare
8577                   Body_Stmts            : constant List_Id := New_List;
8578                   Constructor_Id        : Entity_Id;
8579                   Constructor_Decl_Node : Node_Id;
8580                   Init_Tags_List        : List_Id;
8581
8582                begin
8583                   Constructor_Id := Make_Temporary (Loc, 'P');
8584
8585                   Constructor_Decl_Node :=
8586                     Make_Subprogram_Declaration (Loc,
8587                       Make_Procedure_Specification (Loc,
8588                         Defining_Unit_Name => Constructor_Id,
8589                         Parameter_Specifications => Parms));
8590
8591                   Set_Is_Imported    (Constructor_Id);
8592                   Set_Is_Constructor (Constructor_Id);
8593                   Set_Interface_Name (Constructor_Id, Interface_Name (E));
8594                   Set_Convention     (Constructor_Id, Convention_CPP);
8595                   Set_Is_Public      (Constructor_Id);
8596                   Set_Has_Completion (Constructor_Id);
8597
8598                   --  Build the init procedure as a wrapper of this constructor
8599
8600                   Parms := Gen_Parameters_Profile (E);
8601
8602                   --  Invoke the C++ constructor
8603
8604                   declare
8605                      Actuals : constant List_Id := New_List;
8606
8607                   begin
8608                      P := First (Parms);
8609                      while Present (P) loop
8610                         Append_To (Actuals,
8611                           New_Occurrence_Of (Defining_Identifier (P), Loc));
8612                         Next (P);
8613                      end loop;
8614
8615                      Append_To (Body_Stmts,
8616                        Make_Procedure_Call_Statement (Loc,
8617                          Name => New_Occurrence_Of (Constructor_Id, Loc),
8618                          Parameter_Associations => Actuals));
8619                   end;
8620
8621                   --  Initialize copies of C++ primary and secondary tags
8622
8623                   Init_Tags_List := New_List;
8624
8625                   declare
8626                      Tag_Elmt : Elmt_Id;
8627                      Tag_Comp : Node_Id;
8628
8629                   begin
8630                      Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
8631                      Tag_Comp := First_Tag_Component (Typ);
8632
8633                      while Present (Tag_Elmt)
8634                        and then Is_Tag (Node (Tag_Elmt))
8635                      loop
8636                         --  Skip the following assertion with primary tags
8637                         --  because Related_Type is not set on primary tag
8638                         --  components
8639
8640                         pragma Assert
8641                           (Tag_Comp = First_Tag_Component (Typ)
8642                              or else Related_Type (Node (Tag_Elmt))
8643                                        = Related_Type (Tag_Comp));
8644
8645                         Append_To (Init_Tags_List,
8646                           Make_Assignment_Statement (Loc,
8647                             Name =>
8648                               New_Occurrence_Of (Node (Tag_Elmt), Loc),
8649                             Expression =>
8650                               Make_Selected_Component (Loc,
8651                                 Prefix        =>
8652                                   Make_Identifier (Loc, Name_uInit),
8653                                 Selector_Name =>
8654                                   New_Occurrence_Of (Tag_Comp, Loc))));
8655
8656                         Tag_Comp := Next_Tag_Component (Tag_Comp);
8657                         Next_Elmt (Tag_Elmt);
8658                      end loop;
8659                   end;
8660
8661                   Append_To (Body_Stmts,
8662                     Make_If_Statement (Loc,
8663                       Condition =>
8664                         Make_Op_Eq (Loc,
8665                           Left_Opnd =>
8666                             New_Occurrence_Of
8667                               (Node (First_Elmt (Access_Disp_Table (Typ))),
8668                                Loc),
8669                           Right_Opnd =>
8670                             Unchecked_Convert_To (RTE (RE_Tag),
8671                               New_Occurrence_Of (RTE (RE_Null_Address), Loc))),
8672                       Then_Statements => Init_Tags_List));
8673
8674                   IP_Body :=
8675                     Make_Subprogram_Body (Loc,
8676                       Specification =>
8677                         Make_Procedure_Specification (Loc,
8678                           Defining_Unit_Name => IP,
8679                           Parameter_Specifications => Parms),
8680                       Declarations => New_List (Constructor_Decl_Node),
8681                       Handled_Statement_Sequence =>
8682                         Make_Handled_Sequence_Of_Statements (Loc,
8683                           Statements => Body_Stmts,
8684                           Exception_Handlers => No_List));
8685
8686                   Discard_Node (IP_Body);
8687                   Set_Init_Proc (Typ, IP);
8688                end;
8689             end if;
8690
8691             --  If this constructor has parameters and all its parameters
8692             --  have defaults then it covers the default constructor. The
8693             --  semantic analyzer ensures that only one constructor with
8694             --  defaults covers the default constructor.
8695
8696             if Present (Parameter_Specifications (Parent (E)))
8697               and then Needs_No_Actuals (E)
8698             then
8699                Covers_Default_Constructor := IP;
8700             end if;
8701          end if;
8702
8703          Next_Entity (E);
8704       end loop;
8705
8706       --  If there are no constructors, mark the type as abstract since we
8707       --  won't be able to declare objects of that type.
8708
8709       if not Found then
8710          Set_Is_Abstract_Type (Typ);
8711       end if;
8712
8713       --  Handle constructor that has all its parameters with defaults and
8714       --  hence it covers the default constructor. We generate a wrapper IP
8715       --  which calls the covering constructor.
8716
8717       if Present (Covers_Default_Constructor) then
8718          declare
8719             Body_Stmts : List_Id;
8720
8721          begin
8722             Loc := Sloc (Covers_Default_Constructor);
8723
8724             Body_Stmts := New_List (
8725               Make_Procedure_Call_Statement (Loc,
8726                 Name                   =>
8727                   New_Occurrence_Of (Covers_Default_Constructor, Loc),
8728                 Parameter_Associations => New_List (
8729                   Make_Identifier (Loc, Name_uInit))));
8730
8731             IP := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
8732
8733             IP_Body :=
8734               Make_Subprogram_Body (Loc,
8735                 Specification              =>
8736                   Make_Procedure_Specification (Loc,
8737                     Defining_Unit_Name       => IP,
8738                     Parameter_Specifications => New_List (
8739                       Make_Parameter_Specification (Loc,
8740                         Defining_Identifier =>
8741                           Make_Defining_Identifier (Loc, Name_uInit),
8742                         Parameter_Type      => New_Occurrence_Of (Typ, Loc)))),
8743
8744                 Declarations               => No_List,
8745
8746                 Handled_Statement_Sequence =>
8747                   Make_Handled_Sequence_Of_Statements (Loc,
8748                     Statements         => Body_Stmts,
8749                     Exception_Handlers => No_List));
8750
8751             Discard_Node (IP_Body);
8752             Set_Init_Proc (Typ, IP);
8753          end;
8754       end if;
8755
8756       --  If the CPP type has constructors then it must import also the default
8757       --  C++ constructor. It is required for default initialization of objects
8758       --  of the type. It is also required to elaborate objects of Ada types
8759       --  that are defined as derivations of this CPP type.
8760
8761       if Has_CPP_Constructors (Typ)
8762         and then No (Init_Proc (Typ))
8763       then
8764          Error_Msg_N ("??default constructor must be imported from C++", Typ);
8765       end if;
8766    end Set_CPP_Constructors;
8767
8768    --------------------------
8769    -- Set_DTC_Entity_Value --
8770    --------------------------
8771
8772    procedure Set_DTC_Entity_Value
8773      (Tagged_Type : Entity_Id;
8774       Prim        : Entity_Id)
8775    is
8776    begin
8777       if Present (Interface_Alias (Prim))
8778         and then Is_Interface
8779                    (Find_Dispatching_Type (Interface_Alias (Prim)))
8780       then
8781          Set_DTC_Entity (Prim,
8782            Find_Interface_Tag
8783              (T     => Tagged_Type,
8784               Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
8785       else
8786          Set_DTC_Entity (Prim,
8787            First_Tag_Component (Tagged_Type));
8788       end if;
8789    end Set_DTC_Entity_Value;
8790
8791    -----------------
8792    -- Tagged_Kind --
8793    -----------------
8794
8795    function Tagged_Kind (T : Entity_Id) return Node_Id is
8796       Conc_Typ : Entity_Id;
8797       Loc      : constant Source_Ptr := Sloc (T);
8798
8799    begin
8800       pragma Assert
8801         (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
8802
8803       --  Abstract kinds
8804
8805       if Is_Abstract_Type (T) then
8806          if Is_Limited_Record (T) then
8807             return New_Occurrence_Of
8808               (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
8809          else
8810             return New_Occurrence_Of
8811               (RTE (RE_TK_Abstract_Tagged), Loc);
8812          end if;
8813
8814       --  Concurrent kinds
8815
8816       elsif Is_Concurrent_Record_Type (T) then
8817          Conc_Typ := Corresponding_Concurrent_Type (T);
8818
8819          if Present (Full_View (Conc_Typ)) then
8820             Conc_Typ := Full_View (Conc_Typ);
8821          end if;
8822
8823          if Ekind (Conc_Typ) = E_Protected_Type then
8824             return New_Occurrence_Of (RTE (RE_TK_Protected), Loc);
8825          else
8826             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
8827             return New_Occurrence_Of (RTE (RE_TK_Task), Loc);
8828          end if;
8829
8830       --  Regular tagged kinds
8831
8832       else
8833          if Is_Limited_Record (T) then
8834             return New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc);
8835          else
8836             return New_Occurrence_Of (RTE (RE_TK_Tagged), Loc);
8837          end if;
8838       end if;
8839    end Tagged_Kind;
8840
8841    --------------
8842    -- Write_DT --
8843    --------------
8844
8845    procedure Write_DT (Typ : Entity_Id) is
8846       Elmt : Elmt_Id;
8847       Prim : Node_Id;
8848
8849    begin
8850       --  Protect this procedure against wrong usage. Required because it will
8851       --  be used directly from GDB
8852
8853       if not (Typ <= Last_Node_Id)
8854         or else not Is_Tagged_Type (Typ)
8855       then
8856          Write_Str ("wrong usage: Write_DT must be used with tagged types");
8857          Write_Eol;
8858          return;
8859       end if;
8860
8861       Write_Int (Int (Typ));
8862       Write_Str (": ");
8863       Write_Name (Chars (Typ));
8864
8865       if Is_Interface (Typ) then
8866          Write_Str (" is interface");
8867       end if;
8868
8869       Write_Eol;
8870
8871       Elmt := First_Elmt (Primitive_Operations (Typ));
8872       while Present (Elmt) loop
8873          Prim := Node (Elmt);
8874          Write_Str  (" - ");
8875
8876          --  Indicate if this primitive will be allocated in the primary
8877          --  dispatch table or in a secondary dispatch table associated
8878          --  with an abstract interface type
8879
8880          if Present (DTC_Entity (Prim)) then
8881             if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
8882                Write_Str ("[P] ");
8883             else
8884                Write_Str ("[s] ");
8885             end if;
8886          end if;
8887
8888          --  Output the node of this primitive operation and its name
8889
8890          Write_Int  (Int (Prim));
8891          Write_Str  (": ");
8892
8893          if Is_Predefined_Dispatching_Operation (Prim) then
8894             Write_Str ("(predefined) ");
8895          end if;
8896
8897          --  Prefix the name of the primitive with its corresponding tagged
8898          --  type to facilitate seeing inherited primitives.
8899
8900          if Present (Alias (Prim)) then
8901             Write_Name
8902               (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
8903          else
8904             Write_Name (Chars (Typ));
8905          end if;
8906
8907          Write_Str (".");
8908          Write_Name (Chars (Prim));
8909
8910          --  Indicate if this primitive has an aliased primitive
8911
8912          if Present (Alias (Prim)) then
8913             Write_Str (" (alias = ");
8914             Write_Int (Int (Alias (Prim)));
8915
8916             --  If the DTC_Entity attribute is already set we can also output
8917             --  the name of the interface covered by this primitive (if any).
8918
8919             if Ekind_In (Alias (Prim), E_Function, E_Procedure)
8920               and then Present (DTC_Entity (Alias (Prim)))
8921               and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
8922             then
8923                Write_Str  (" from interface ");
8924                Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
8925             end if;
8926
8927             if Present (Interface_Alias (Prim)) then
8928                Write_Str  (", AI_Alias of ");
8929
8930                if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
8931                   Write_Str ("null primitive ");
8932                end if;
8933
8934                Write_Name
8935                  (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
8936                Write_Char (':');
8937                Write_Int  (Int (Interface_Alias (Prim)));
8938             end if;
8939
8940             Write_Str (")");
8941          end if;
8942
8943          --  Display the final position of this primitive in its associated
8944          --  (primary or secondary) dispatch table
8945
8946          if Present (DTC_Entity (Prim))
8947            and then DT_Position (Prim) /= No_Uint
8948          then
8949             Write_Str (" at #");
8950             Write_Int (UI_To_Int (DT_Position (Prim)));
8951          end if;
8952
8953          if Is_Abstract_Subprogram (Prim) then
8954             Write_Str (" is abstract;");
8955
8956          --  Check if this is a null primitive
8957
8958          elsif Comes_From_Source (Prim)
8959            and then Ekind (Prim) = E_Procedure
8960            and then Null_Present (Parent (Prim))
8961          then
8962             Write_Str (" is null;");
8963          end if;
8964
8965          if Is_Eliminated (Ultimate_Alias (Prim)) then
8966             Write_Str (" (eliminated)");
8967          end if;
8968
8969          if Is_Imported (Prim)
8970            and then Convention (Prim) = Convention_CPP
8971          then
8972             Write_Str (" (C++)");
8973          end if;
8974
8975          Write_Eol;
8976
8977          Next_Elmt (Elmt);
8978       end loop;
8979    end Write_DT;
8980
8981 end Exp_Disp;