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