gcc/ada/exp_disp.adb

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