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