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