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