gcc/ada/exp_disp.adb

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