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