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