gcc/ada/exp_disp.adb

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