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