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