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