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