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