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