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