gcc/ada/exp_disp.adb

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