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