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