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