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 Building_Static_DT (Typ)
4064          then
4065             for J in 1 .. Nb_Prim loop
4066                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
4067             end loop;
4068
4069          else
4070             declare
4071                CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
4072                E            : Entity_Id;
4073                Prim_Pos     : Nat;
4074                Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4075                Thunk_Code   : Node_Id;
4076                Thunk_Id     : Entity_Id;
4077
4078             begin
4079                Prim_Table := (others => Empty);
4080
4081                Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
4082                while Present (Prim_Elmt) loop
4083                   Prim     := Node (Prim_Elmt);
4084                   E        := Ultimate_Alias (Prim);
4085                   Prim_Pos := UI_To_Int (DT_Position (E));
4086
4087                   --  Do not reference predefined primitives because they are
4088                   --  located in a separate dispatch table; skip abstract and
4089                   --  eliminated primitives; skip primitives located in the C++
4090                   --  part of the dispatch table because their slot is set by
4091                   --  the IC routine.
4092
4093                   if not Is_Predefined_Dispatching_Operation (Prim)
4094                     and then Present (Interface_Alias (Prim))
4095                     and then not Is_Abstract_Subprogram (Alias (Prim))
4096                     and then not Is_Eliminated (Alias (Prim))
4097                     and then (not Is_CPP_Class (Root_Type (Typ))
4098                                or else Prim_Pos > CPP_Nb_Prims)
4099                     and then Find_Dispatching_Type
4100                                (Interface_Alias (Prim)) = Iface
4101
4102                      --  Generate the code of the thunk only if the abstract
4103                      --  interface type is not an immediate ancestor of
4104                      --  Tagged_Type. Otherwise the DT associated with the
4105                      --  interface is the primary DT.
4106
4107                     and then not Is_Ancestor (Iface, Typ)
4108                   then
4109                      if not Build_Thunks then
4110                         Prim_Pos :=
4111                           UI_To_Int (DT_Position (Interface_Alias (Prim)));
4112                         Prim_Table (Prim_Pos) := Alias (Prim);
4113
4114                      else
4115                         Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
4116
4117                         if Present (Thunk_Id) then
4118                            Prim_Pos :=
4119                              UI_To_Int (DT_Position (Interface_Alias (Prim)));
4120
4121                            Prim_Table (Prim_Pos) := Thunk_Id;
4122                            Append_To (Result, Thunk_Code);
4123                         end if;
4124                      end if;
4125                   end if;
4126
4127                   Next_Elmt (Prim_Elmt);
4128                end loop;
4129
4130                for J in Prim_Table'Range loop
4131                   if Present (Prim_Table (J)) then
4132                      New_Node :=
4133                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
4134                          Make_Attribute_Reference (Loc,
4135                            Prefix => New_Reference_To (Prim_Table (J), Loc),
4136                            Attribute_Name => Name_Unrestricted_Access));
4137
4138                   else
4139                      New_Node := Make_Null (Loc);
4140                   end if;
4141
4142                   Append_To (Prim_Ops_Aggr_List, New_Node);
4143                end loop;
4144             end;
4145          end if;
4146
4147          New_Node :=
4148            Make_Aggregate (Loc,
4149              Expressions => Prim_Ops_Aggr_List);
4150
4151          Append_To (DT_Aggr_List, New_Node);
4152
4153          --  Remember aggregates initializing dispatch tables
4154
4155          Append_Elmt (New_Node, DT_Aggr);
4156
4157          --  Note: Secondary dispatch tables cannot be declared constant
4158          --  because the component Offset_To_Top is currently initialized
4159          --  by the IP routine.
4160
4161          Append_To (Result,
4162            Make_Object_Declaration (Loc,
4163              Defining_Identifier => Iface_DT,
4164              Aliased_Present     => True,
4165              Constant_Present    => False,
4166
4167              Object_Definition   =>
4168                Make_Subtype_Indication (Loc,
4169                  Subtype_Mark => New_Reference_To
4170                                    (RTE (RE_Dispatch_Table_Wrapper), Loc),
4171                  Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
4172                                    Constraints => DT_Constr_List)),
4173
4174              Expression          =>
4175                Make_Aggregate (Loc,
4176                  Expressions => DT_Aggr_List)));
4177
4178          Append_To (Result,
4179            Make_Attribute_Definition_Clause (Loc,
4180              Name       => New_Reference_To (Iface_DT, Loc),
4181              Chars      => Name_Alignment,
4182
4183              Expression =>
4184                Make_Attribute_Reference (Loc,
4185                  Prefix         =>
4186                    New_Reference_To (RTE (RE_Integer_Address), Loc),
4187                  Attribute_Name => Name_Alignment)));
4188
4189          if Exporting_Table then
4190             Export_DT (Typ, Iface_DT, Suffix_Index);
4191
4192          --  Generate code to create the pointer to the dispatch table
4193
4194          --    Iface_DT_Ptr : Tag := Tag!(DT.Prims_Ptr'Address);
4195
4196          --  Note: This declaration is not added here if the table is exported
4197          --  because in such case Make_Tags has already added this declaration.
4198
4199          else
4200             Append_To (Result,
4201               Make_Object_Declaration (Loc,
4202                 Defining_Identifier => Iface_DT_Ptr,
4203                 Constant_Present    => True,
4204
4205                 Object_Definition   =>
4206                   New_Reference_To (RTE (RE_Interface_Tag), Loc),
4207
4208                 Expression          =>
4209                   Unchecked_Convert_To (RTE (RE_Interface_Tag),
4210                     Make_Attribute_Reference (Loc,
4211                       Prefix         =>
4212                         Make_Selected_Component (Loc,
4213                           Prefix        => New_Reference_To (Iface_DT, Loc),
4214                           Selector_Name =>
4215                             New_Occurrence_Of
4216                               (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4217                       Attribute_Name => Name_Address))));
4218          end if;
4219
4220          Append_To (Result,
4221            Make_Object_Declaration (Loc,
4222              Defining_Identifier => Predef_Prims_Ptr,
4223              Constant_Present    => True,
4224
4225              Object_Definition   =>
4226                New_Reference_To (RTE (RE_Address), Loc),
4227
4228              Expression          =>
4229                Make_Attribute_Reference (Loc,
4230                  Prefix         =>
4231                    Make_Selected_Component (Loc,
4232                      Prefix        => New_Reference_To (Iface_DT, Loc),
4233                      Selector_Name =>
4234                        New_Occurrence_Of
4235                          (RTE_Record_Component (RE_Predef_Prims), Loc)),
4236                  Attribute_Name => Name_Address)));
4237
4238          --  Remember entities containing dispatch tables
4239
4240          Append_Elmt (Predef_Prims, DT_Decl);
4241          Append_Elmt (Iface_DT, DT_Decl);
4242       end Make_Secondary_DT;
4243
4244       --  Local variables
4245
4246       Elab_Code          : constant List_Id := New_List;
4247       Result             : constant List_Id := New_List;
4248       Tname              : constant Name_Id := Chars (Typ);
4249       AI                 : Elmt_Id;
4250       AI_Tag_Elmt        : Elmt_Id;
4251       AI_Tag_Comp        : Elmt_Id;
4252       DT_Aggr_List       : List_Id;
4253       DT_Constr_List     : List_Id;
4254       DT_Ptr             : Entity_Id;
4255       ITable             : Node_Id;
4256       I_Depth            : Nat := 0;
4257       Iface_Table_Node   : Node_Id;
4258       Name_ITable        : Name_Id;
4259       Nb_Predef_Prims    : Nat := 0;
4260       Nb_Prim            : Nat := 0;
4261       New_Node           : Node_Id;
4262       Num_Ifaces         : Nat := 0;
4263       Parent_Typ         : Entity_Id;
4264       Prim               : Entity_Id;
4265       Prim_Elmt          : Elmt_Id;
4266       Prim_Ops_Aggr_List : List_Id;
4267       Suffix_Index       : Int;
4268       Typ_Comps          : Elist_Id;
4269       Typ_Ifaces         : Elist_Id;
4270       TSD_Aggr_List      : List_Id;
4271       TSD_Tags_List      : List_Id;
4272
4273       --  The following name entries are used by Make_DT to generate a number
4274       --  of entities related to a tagged type. These entities may be generated
4275       --  in a scope other than that of the tagged type declaration, and if
4276       --  the entities for two tagged types with the same name happen to be
4277       --  generated in the same scope, we have to take care to use different
4278       --  names. This is achieved by means of a unique serial number appended
4279       --  to each generated entity name.
4280
4281       Name_DT           : constant Name_Id :=
4282                             New_External_Name (Tname, 'T', Suffix_Index => -1);
4283       Name_Exname       : constant Name_Id :=
4284                             New_External_Name (Tname, 'E', Suffix_Index => -1);
4285       Name_HT_Link      : constant Name_Id :=
4286                             New_External_Name (Tname, 'H', Suffix_Index => -1);
4287       Name_Predef_Prims : constant Name_Id :=
4288                             New_External_Name (Tname, 'R', Suffix_Index => -1);
4289       Name_SSD          : constant Name_Id :=
4290                             New_External_Name (Tname, 'S', Suffix_Index => -1);
4291       Name_TSD          : constant Name_Id :=
4292                             New_External_Name (Tname, 'B', Suffix_Index => -1);
4293
4294       --  Entities built with above names
4295
4296       DT           : constant Entity_Id :=
4297                        Make_Defining_Identifier (Loc, Name_DT);
4298       Exname       : constant Entity_Id :=
4299                        Make_Defining_Identifier (Loc, Name_Exname);
4300       HT_Link      : constant Entity_Id :=
4301                        Make_Defining_Identifier (Loc, Name_HT_Link);
4302       Predef_Prims : constant Entity_Id :=
4303                        Make_Defining_Identifier (Loc, Name_Predef_Prims);
4304       SSD          : constant Entity_Id :=
4305                        Make_Defining_Identifier (Loc, Name_SSD);
4306       TSD          : constant Entity_Id :=
4307                        Make_Defining_Identifier (Loc, Name_TSD);
4308
4309    --  Start of processing for Make_DT
4310
4311    begin
4312       pragma Assert (Is_Frozen (Typ));
4313
4314       --  Handle cases in which there is no need to build the dispatch table
4315
4316       if Has_Dispatch_Table (Typ)
4317         or else No (Access_Disp_Table (Typ))
4318         or else Is_CPP_Class (Typ)
4319         or else Convention (Typ) = Convention_CIL
4320         or else Convention (Typ) = Convention_Java
4321       then
4322          return Result;
4323
4324       elsif No_Run_Time_Mode then
4325          Error_Msg_CRT ("tagged types", Typ);
4326          return Result;
4327
4328       elsif not RTE_Available (RE_Tag) then
4329          Append_To (Result,
4330            Make_Object_Declaration (Loc,
4331              Defining_Identifier => Node (First_Elmt
4332                                            (Access_Disp_Table (Typ))),
4333              Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
4334              Constant_Present    => True,
4335              Expression =>
4336                Unchecked_Convert_To (RTE (RE_Tag),
4337                  New_Reference_To (RTE (RE_Null_Address), Loc))));
4338
4339          Analyze_List (Result, Suppress => All_Checks);
4340          Error_Msg_CRT ("tagged types", Typ);
4341          return Result;
4342       end if;
4343
4344       --  Ensure that the value of Max_Predef_Prims defined in a-tags is
4345       --  correct. Valid values are 10 under configurable runtime or 16
4346       --  with full runtime.
4347
4348       if RTE_Available (RE_Interface_Data) then
4349          if Max_Predef_Prims /= 16 then
4350             Error_Msg_N ("run-time library configuration error", Typ);
4351             return Result;
4352          end if;
4353       else
4354          if Max_Predef_Prims /= 10 then
4355             Error_Msg_N ("run-time library configuration error", Typ);
4356             Error_Msg_CRT ("tagged types", Typ);
4357             return Result;
4358          end if;
4359       end if;
4360
4361       --  Initialize Parent_Typ handling private types
4362
4363       Parent_Typ := Etype (Typ);
4364
4365       if Present (Full_View (Parent_Typ)) then
4366          Parent_Typ := Full_View (Parent_Typ);
4367       end if;
4368
4369       --  Ensure that all the primitives are frozen. This is only required when
4370       --  building static dispatch tables --- the primitives must be frozen to
4371       --  be referenced (otherwise we have problems with the backend). It is
4372       --  not a requirement with nonstatic dispatch tables because in this case
4373       --  we generate now an empty dispatch table; the extra code required to
4374       --  register the primitives in the slots will be generated later --- when
4375       --  each primitive is frozen (see Freeze_Subprogram).
4376
4377       if Building_Static_DT (Typ) then
4378          declare
4379             Save      : constant Boolean := Freezing_Library_Level_Tagged_Type;
4380             Prim      : Entity_Id;
4381             Prim_Elmt : Elmt_Id;
4382             Frnodes   : List_Id;
4383
4384          begin
4385             Freezing_Library_Level_Tagged_Type := True;
4386
4387             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4388             while Present (Prim_Elmt) loop
4389                Prim    := Node (Prim_Elmt);
4390                Frnodes := Freeze_Entity (Prim, Loc);
4391
4392                declare
4393                   F : Entity_Id;
4394
4395                begin
4396                   F := First_Formal (Prim);
4397                   while Present (F) loop
4398                      Check_Premature_Freezing (Prim, Etype (F));
4399                      Next_Formal (F);
4400                   end loop;
4401
4402                   Check_Premature_Freezing (Prim, Etype (Prim));
4403                end;
4404
4405                if Present (Frnodes) then
4406                   Append_List_To (Result, Frnodes);
4407                end if;
4408
4409                Next_Elmt (Prim_Elmt);
4410             end loop;
4411
4412             Freezing_Library_Level_Tagged_Type := Save;
4413          end;
4414       end if;
4415
4416       --  Ada 2005 (AI-251): Build the secondary dispatch tables
4417
4418       if Has_Interfaces (Typ) then
4419          Collect_Interface_Components (Typ, Typ_Comps);
4420
4421          --  Each secondary dispatch table is assigned an unique positive
4422          --  suffix index; such value also corresponds with the location of
4423          --  its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
4424
4425          --  Note: This value must be kept sync with the Suffix_Index values
4426          --  generated by Make_Tags
4427
4428          Suffix_Index := 1;
4429          AI_Tag_Elmt  :=
4430            Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4431
4432          AI_Tag_Comp := First_Elmt (Typ_Comps);
4433          while Present (AI_Tag_Comp) loop
4434             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
4435
4436             --  Build the secondary table containing pointers to thunks
4437
4438             Make_Secondary_DT
4439              (Typ             => Typ,
4440               Iface           => Base_Type (Related_Type (Node (AI_Tag_Comp))),
4441               Suffix_Index    => Suffix_Index,
4442               Num_Iface_Prims => UI_To_Int
4443                                    (DT_Entry_Count (Node (AI_Tag_Comp))),
4444               Iface_DT_Ptr    => Node (AI_Tag_Elmt),
4445               Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4446               Build_Thunks    => True,
4447               Result          => Result);
4448
4449             --  Skip secondary dispatch table referencing thunks to predefined
4450             --  primitives.
4451
4452             Next_Elmt (AI_Tag_Elmt);
4453             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
4454
4455             --  Secondary dispatch table referencing user-defined primitives
4456             --  covered by this interface.
4457
4458             Next_Elmt (AI_Tag_Elmt);
4459             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
4460
4461             --  Build the secondary table containing pointers to primitives
4462             --  (used to give support to Generic Dispatching Constructors).
4463
4464             Make_Secondary_DT
4465               (Typ              => Typ,
4466                Iface            => Base_Type
4467                                      (Related_Type (Node (AI_Tag_Comp))),
4468                Suffix_Index     => -1,
4469                Num_Iface_Prims  => UI_To_Int
4470                                      (DT_Entry_Count (Node (AI_Tag_Comp))),
4471                Iface_DT_Ptr     => Node (AI_Tag_Elmt),
4472                Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4473                Build_Thunks     => False,
4474                Result           => Result);
4475
4476             --  Skip secondary dispatch table referencing predefined primitives
4477
4478             Next_Elmt (AI_Tag_Elmt);
4479             pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
4480
4481             Suffix_Index := Suffix_Index + 1;
4482             Next_Elmt (AI_Tag_Elmt);
4483             Next_Elmt (AI_Tag_Comp);
4484          end loop;
4485       end if;
4486
4487       --  Get the _tag entity and number of primitives of its dispatch 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               Fully_Qualified_Name_String (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       --            Type_Is_Abstract   => <<boolean-value>>,
4683       --            RC_Offset          => <<integer-value>>,
4684       --            [ Size_Func         => Size_Prim'Access ]
4685       --            [ Interfaces_Table  => <<access-value>> ]
4686       --            [ SSD               => SSD_Table'Address ]
4687       --            Tags_Table         => (0 => null,
4688       --                                   1 => Parent'Tag
4689       --                                   ...);
4690       --   for TSD'Alignment use Address'Alignment
4691
4692       TSD_Aggr_List := New_List;
4693
4694       --  Idepth: Count ancestors to compute the inheritance depth. For private
4695       --  extensions, always go to the full view in order to compute the real
4696       --  inheritance depth.
4697
4698       declare
4699          Current_Typ : Entity_Id;
4700          Parent_Typ  : Entity_Id;
4701
4702       begin
4703          I_Depth     := 0;
4704          Current_Typ := Typ;
4705          loop
4706             Parent_Typ := Etype (Current_Typ);
4707
4708             if Is_Private_Type (Parent_Typ) then
4709                Parent_Typ := Full_View (Base_Type (Parent_Typ));
4710             end if;
4711
4712             exit when Parent_Typ = Current_Typ;
4713
4714             I_Depth := I_Depth + 1;
4715             Current_Typ := Parent_Typ;
4716          end loop;
4717       end;
4718
4719       Append_To (TSD_Aggr_List,
4720         Make_Integer_Literal (Loc, I_Depth));
4721
4722       --  Access_Level
4723
4724       Append_To (TSD_Aggr_List,
4725         Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
4726
4727       --  Expanded_Name
4728
4729       Append_To (TSD_Aggr_List,
4730         Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4731           Make_Attribute_Reference (Loc,
4732             Prefix => New_Reference_To (Exname, Loc),
4733             Attribute_Name => Name_Address)));
4734
4735       --  External_Tag of a local tagged type
4736
4737       --     <typ>A : constant String :=
4738       --                "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4739
4740       --  The reason we generate this strange name is that we do not want to
4741       --  enter local tagged types in the global hash table used to compute
4742       --  the Internal_Tag attribute for two reasons:
4743
4744       --    1. It is hard to avoid a tasking race condition for entering the
4745       --    entry into the hash table.
4746
4747       --    2. It would cause a storage leak, unless we rig up considerable
4748       --    mechanism to remove the entry from the hash table on exit.
4749
4750       --  So what we do is to generate the above external tag name, where the
4751       --  hex address is the address of the local dispatch table (i.e. exactly
4752       --  the value we want if Internal_Tag is computed from this string).
4753
4754       --  Of course this value will only be valid if the tagged type is still
4755       --  in scope, but it clearly must be erroneous to compute the internal
4756       --  tag of a tagged type that is out of scope!
4757
4758       --  We don't do this processing if an explicit external tag has been
4759       --  specified. That's an odd case for which we have already issued a
4760       --  warning, where we will not be able to compute the internal tag.
4761
4762       if not Is_Library_Level_Entity (Typ)
4763         and then not Has_External_Tag_Rep_Clause (Typ)
4764       then
4765          declare
4766             Exname      : constant Entity_Id :=
4767                             Make_Defining_Identifier (Loc,
4768                               New_External_Name (Tname, 'A'));
4769
4770             Full_Name   : constant String_Id :=
4771                             Fully_Qualified_Name_String (First_Subtype (Typ));
4772             Str1_Id     : String_Id;
4773             Str2_Id     : String_Id;
4774
4775          begin
4776             --  Generate:
4777             --    Str1 = "Internal tag at 16#";
4778
4779             Start_String;
4780             Store_String_Chars ("Internal tag at 16#");
4781             Str1_Id := End_String;
4782
4783             --  Generate:
4784             --    Str2 = "#: <type-full-name>";
4785
4786             Start_String;
4787             Store_String_Chars ("#: ");
4788             Store_String_Chars (Full_Name);
4789             Str2_Id := End_String;
4790
4791             --  Generate:
4792             --    Exname : constant String :=
4793             --               Str1 & Address_Image (Tag) & Str2;
4794
4795             if RTE_Available (RE_Address_Image) then
4796                Append_To (Result,
4797                  Make_Object_Declaration (Loc,
4798                    Defining_Identifier => Exname,
4799                    Constant_Present    => True,
4800                    Object_Definition   => New_Reference_To
4801                                             (Standard_String, Loc),
4802                    Expression =>
4803                      Make_Op_Concat (Loc,
4804                        Left_Opnd =>
4805                          Make_String_Literal (Loc, Str1_Id),
4806                        Right_Opnd =>
4807                          Make_Op_Concat (Loc,
4808                            Left_Opnd =>
4809                              Make_Function_Call (Loc,
4810                                Name =>
4811                                  New_Reference_To
4812                                    (RTE (RE_Address_Image), Loc),
4813                                Parameter_Associations => New_List (
4814                                  Unchecked_Convert_To (RTE (RE_Address),
4815                                    New_Reference_To (DT_Ptr, Loc)))),
4816                            Right_Opnd =>
4817                              Make_String_Literal (Loc, Str2_Id)))));
4818
4819             else
4820                Append_To (Result,
4821                  Make_Object_Declaration (Loc,
4822                    Defining_Identifier => Exname,
4823                    Constant_Present    => True,
4824                    Object_Definition   => New_Reference_To
4825                                             (Standard_String, Loc),
4826                    Expression =>
4827                      Make_Op_Concat (Loc,
4828                        Left_Opnd =>
4829                          Make_String_Literal (Loc, Str1_Id),
4830                        Right_Opnd =>
4831                          Make_String_Literal (Loc, Str2_Id))));
4832             end if;
4833
4834             New_Node :=
4835               Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4836                 Make_Attribute_Reference (Loc,
4837                   Prefix => New_Reference_To (Exname, Loc),
4838                   Attribute_Name => Name_Address));
4839          end;
4840
4841       --  External tag of a library-level tagged type: Check for a definition
4842       --  of External_Tag. The clause is considered only if it applies to this
4843       --  specific tagged type, as opposed to one of its ancestors.
4844       --  If the type is an unconstrained type extension, we are building the
4845       --  dispatch table of its anonymous base type, so the external tag, if
4846       --  any was specified, must be retrieved from the first subtype. Go to
4847       --  the full view in case the clause is in the private part.
4848
4849       else
4850          declare
4851             Def : constant Node_Id := Get_Attribute_Definition_Clause
4852                                         (Underlying_Type (First_Subtype (Typ)),
4853                                          Attribute_External_Tag);
4854
4855             Old_Val : String_Id;
4856             New_Val : String_Id;
4857             E       : Entity_Id;
4858
4859          begin
4860             if not Present (Def)
4861               or else Entity (Name (Def)) /= First_Subtype (Typ)
4862             then
4863                New_Node :=
4864                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4865                    Make_Attribute_Reference (Loc,
4866                      Prefix         => New_Reference_To (Exname, Loc),
4867                      Attribute_Name => Name_Address));
4868             else
4869                Old_Val := Strval (Expr_Value_S (Expression (Def)));
4870
4871                --  For the rep clause "for <typ>'external_tag use y" generate:
4872
4873                --     <typ>A : constant string := y;
4874                --
4875                --  <typ>A'Address is used to set the External_Tag component
4876                --  of the TSD
4877
4878                --  Create a new nul terminated string if it is not already
4879
4880                if String_Length (Old_Val) > 0
4881                  and then
4882                   Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
4883                then
4884                   New_Val := Old_Val;
4885                else
4886                   Start_String (Old_Val);
4887                   Store_String_Char (Get_Char_Code (ASCII.NUL));
4888                   New_Val := End_String;
4889                end if;
4890
4891                E := Make_Defining_Identifier (Loc,
4892                       New_External_Name (Chars (Typ), 'A'));
4893
4894                Append_To (Result,
4895                  Make_Object_Declaration (Loc,
4896                    Defining_Identifier => E,
4897                    Constant_Present    => True,
4898                    Object_Definition   =>
4899                      New_Reference_To (Standard_String, Loc),
4900                    Expression          =>
4901                      Make_String_Literal (Loc, New_Val)));
4902
4903                New_Node :=
4904                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4905                    Make_Attribute_Reference (Loc,
4906                      Prefix => New_Reference_To (E, Loc),
4907                      Attribute_Name => Name_Address));
4908             end if;
4909          end;
4910       end if;
4911
4912       Append_To (TSD_Aggr_List, New_Node);
4913
4914       --  HT_Link
4915
4916       if RTE_Available (RE_Register_Tag) then
4917          Append_To (TSD_Aggr_List,
4918            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4919              Make_Attribute_Reference (Loc,
4920                Prefix => New_Reference_To (HT_Link, Loc),
4921                Attribute_Name => Name_Address)));
4922       else
4923          Append_To (TSD_Aggr_List,
4924            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4925              New_Reference_To (RTE (RE_Null_Address), Loc)));
4926       end if;
4927
4928       --  Transportable: Set for types that can be used in remote calls
4929       --  with respect to E.4(18) legality rules.
4930
4931       declare
4932          Transportable : Entity_Id;
4933
4934       begin
4935          Transportable :=
4936            Boolean_Literals
4937              (Is_Pure (Typ)
4938                 or else Is_Shared_Passive (Typ)
4939                 or else
4940                   ((Is_Remote_Types (Typ)
4941                       or else Is_Remote_Call_Interface (Typ))
4942                    and then Original_View_In_Visible_Part (Typ))
4943                 or else not Comes_From_Source (Typ));
4944
4945          Append_To (TSD_Aggr_List,
4946             New_Occurrence_Of (Transportable, Loc));
4947       end;
4948
4949       --  Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is
4950       --  not available in the HIE runtime.
4951
4952       if RTE_Record_Component_Available (RE_Type_Is_Abstract) then
4953          declare
4954             Type_Is_Abstract : Entity_Id;
4955
4956          begin
4957             Type_Is_Abstract :=
4958               Boolean_Literals (Is_Abstract_Type (Typ));
4959
4960             Append_To (TSD_Aggr_List,
4961                New_Occurrence_Of (Type_Is_Abstract, Loc));
4962          end;
4963       end if;
4964
4965       --  RC_Offset: These are the valid values and their meaning:
4966
4967       --   >0: For simple types with controlled components is
4968       --         type._record_controller'position
4969
4970       --    0: For types with no controlled components
4971
4972       --   -1: For complex types with controlled components where the position
4973       --       of the record controller is not statically computable but there
4974       --       are controlled components at this level. The _Controller field
4975       --       is available right after the _parent.
4976
4977       --   -2: There are no controlled components at this level. We need to
4978       --       get the position from the parent.
4979
4980       declare
4981          RC_Offset_Node : Node_Id;
4982
4983       begin
4984          if not Has_Controlled_Component (Typ) then
4985             RC_Offset_Node := Make_Integer_Literal (Loc, 0);
4986
4987          elsif Etype (Typ) /= Typ
4988            and then Has_Discriminants (Parent_Typ)
4989          then
4990             if Has_New_Controlled_Component (Typ) then
4991                RC_Offset_Node := Make_Integer_Literal (Loc, -1);
4992             else
4993                RC_Offset_Node := Make_Integer_Literal (Loc, -2);
4994             end if;
4995          else
4996             RC_Offset_Node :=
4997               Make_Attribute_Reference (Loc,
4998                 Prefix =>
4999                   Make_Selected_Component (Loc,
5000                     Prefix => New_Reference_To (Typ, Loc),
5001                     Selector_Name =>
5002                       New_Reference_To (Controller_Component (Typ), Loc)),
5003                 Attribute_Name => Name_Position);
5004
5005             --  This is not proper Ada code to use the attribute 'Position
5006             --  on something else than an object but this is supported by
5007             --  the back end (see comment on the Bit_Component attribute in
5008             --  sem_attr). So we avoid semantic checking here.
5009
5010             --  Is this documented in sinfo.ads??? it should be!
5011
5012             Set_Analyzed (RC_Offset_Node);
5013             Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
5014             Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
5015             Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
5016               RTE (RE_Record_Controller));
5017             Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
5018          end if;
5019
5020          Append_To (TSD_Aggr_List, RC_Offset_Node);
5021       end;
5022
5023       --  Size_Func
5024
5025       if RTE_Record_Component_Available (RE_Size_Func) then
5026
5027          --  Initialize this field to Null_Address if we are not building
5028          --  static dispatch tables static or if the size function is not
5029          --  available. In the former case we cannot initialize this field
5030          --  until the function is frozen and registered in the dispatch
5031          --  table (see Register_Primitive).
5032
5033          if not Building_Static_DT (Typ) or else not Has_DT (Typ) then
5034             Append_To (TSD_Aggr_List,
5035               Unchecked_Convert_To (RTE (RE_Size_Ptr),
5036                 New_Reference_To (RTE (RE_Null_Address), Loc)));
5037
5038          else
5039             declare
5040                Prim_Elmt : Elmt_Id;
5041                Prim      : Entity_Id;
5042                Size_Comp : Node_Id;
5043
5044             begin
5045                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5046                while Present (Prim_Elmt) loop
5047                   Prim := Node (Prim_Elmt);
5048
5049                   if Chars (Prim) = Name_uSize then
5050                      Prim := Ultimate_Alias (Prim);
5051
5052                      if Is_Abstract_Subprogram (Prim) then
5053                         Size_Comp :=
5054                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
5055                             New_Reference_To (RTE (RE_Null_Address), Loc));
5056                      else
5057                         Size_Comp :=
5058                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
5059                             Make_Attribute_Reference (Loc,
5060                               Prefix => New_Reference_To (Prim, Loc),
5061                               Attribute_Name => Name_Unrestricted_Access));
5062                      end if;
5063
5064                      exit;
5065                   end if;
5066
5067                   Next_Elmt (Prim_Elmt);
5068                end loop;
5069
5070                pragma Assert (Present (Size_Comp));
5071                Append_To (TSD_Aggr_List, Size_Comp);
5072             end;
5073          end if;
5074       end if;
5075
5076       --  Interfaces_Table (required for AI-405)
5077
5078       if RTE_Record_Component_Available (RE_Interfaces_Table) then
5079
5080          --  Count the number of interface types implemented by Typ
5081
5082          Collect_Interfaces (Typ, Typ_Ifaces);
5083
5084          AI := First_Elmt (Typ_Ifaces);
5085          while Present (AI) loop
5086             Num_Ifaces := Num_Ifaces + 1;
5087             Next_Elmt (AI);
5088          end loop;
5089
5090          if Num_Ifaces = 0 then
5091             Iface_Table_Node := Make_Null (Loc);
5092
5093          --  Generate the Interface_Table object
5094
5095          else
5096             declare
5097                TSD_Ifaces_List : constant List_Id := New_List;
5098                Elmt       : Elmt_Id;
5099                Sec_DT_Tag : Node_Id;
5100
5101             begin
5102                AI := First_Elmt (Typ_Ifaces);
5103                while Present (AI) loop
5104                   if Is_Ancestor (Node (AI), Typ) then
5105                      Sec_DT_Tag :=
5106                        New_Reference_To (DT_Ptr, Loc);
5107                   else
5108                      Elmt :=
5109                        Next_Elmt
5110                         (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5111                      pragma Assert (Has_Thunks (Node (Elmt)));
5112
5113                      while Is_Tag (Node (Elmt))
5114                         and then not
5115                           Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
5116                      loop
5117                         pragma Assert (Has_Thunks (Node (Elmt)));
5118                         Next_Elmt (Elmt);
5119                         pragma Assert (Has_Thunks (Node (Elmt)));
5120                         Next_Elmt (Elmt);
5121                         pragma Assert (not Has_Thunks (Node (Elmt)));
5122                         Next_Elmt (Elmt);
5123                         pragma Assert (not Has_Thunks (Node (Elmt)));
5124                         Next_Elmt (Elmt);
5125                      end loop;
5126
5127                      pragma Assert (Ekind (Node (Elmt)) = E_Constant
5128                        and then not
5129                          Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
5130                      Sec_DT_Tag :=
5131                        New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
5132                                          Loc);
5133                   end if;
5134
5135                   Append_To (TSD_Ifaces_List,
5136                      Make_Aggregate (Loc,
5137                        Expressions => New_List (
5138
5139                         --  Iface_Tag
5140
5141                         Unchecked_Convert_To (RTE (RE_Tag),
5142                           New_Reference_To
5143                             (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
5144                              Loc)),
5145
5146                         --  Static_Offset_To_Top
5147
5148                         New_Reference_To (Standard_True, Loc),
5149
5150                         --  Offset_To_Top_Value
5151
5152                         Make_Integer_Literal (Loc, 0),
5153
5154                         --  Offset_To_Top_Func
5155
5156                         Make_Null (Loc),
5157
5158                         --  Secondary_DT
5159
5160                         Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
5161
5162                         )));
5163
5164                   Next_Elmt (AI);
5165                end loop;
5166
5167                Name_ITable := New_External_Name (Tname, 'I');
5168                ITable      := Make_Defining_Identifier (Loc, Name_ITable);
5169                Set_Is_Statically_Allocated (ITable,
5170                  Is_Library_Level_Tagged_Type (Typ));
5171
5172                --  The table of interfaces is not constant; its slots are
5173                --  filled at run time by the IP routine using attribute
5174                --  'Position to know the location of the tag components
5175                --  (and this attribute cannot be safely used before the
5176                --  object is initialized).
5177
5178                Append_To (Result,
5179                  Make_Object_Declaration (Loc,
5180                    Defining_Identifier => ITable,
5181                    Aliased_Present     => True,
5182                    Constant_Present    => False,
5183                    Object_Definition   =>
5184                      Make_Subtype_Indication (Loc,
5185                        Subtype_Mark =>
5186                          New_Reference_To (RTE (RE_Interface_Data), Loc),
5187                        Constraint => Make_Index_Or_Discriminant_Constraint
5188                          (Loc,
5189                           Constraints => New_List (
5190                             Make_Integer_Literal (Loc, Num_Ifaces)))),
5191
5192                    Expression => Make_Aggregate (Loc,
5193                      Expressions => New_List (
5194                        Make_Integer_Literal (Loc, Num_Ifaces),
5195                        Make_Aggregate (Loc,
5196                          Expressions => TSD_Ifaces_List)))));
5197
5198                Append_To (Result,
5199                  Make_Attribute_Definition_Clause (Loc,
5200                    Name       => New_Reference_To (ITable, Loc),
5201                    Chars      => Name_Alignment,
5202                    Expression =>
5203                      Make_Attribute_Reference (Loc,
5204                        Prefix =>
5205                          New_Reference_To (RTE (RE_Integer_Address), Loc),
5206                        Attribute_Name => Name_Alignment)));
5207
5208                Iface_Table_Node :=
5209                  Make_Attribute_Reference (Loc,
5210                    Prefix         => New_Reference_To (ITable, Loc),
5211                    Attribute_Name => Name_Unchecked_Access);
5212             end;
5213          end if;
5214
5215          Append_To (TSD_Aggr_List, Iface_Table_Node);
5216       end if;
5217
5218       --  Generate the Select Specific Data table for synchronized types that
5219       --  implement synchronized interfaces. The size of the table is
5220       --  constrained by the number of non-predefined primitive operations.
5221
5222       if RTE_Record_Component_Available (RE_SSD) then
5223          if Ada_Version >= Ada_05
5224            and then Has_DT (Typ)
5225            and then Is_Concurrent_Record_Type (Typ)
5226            and then Has_Interfaces (Typ)
5227            and then Nb_Prim > 0
5228            and then not Is_Abstract_Type (Typ)
5229            and then not Is_Controlled (Typ)
5230            and then not Restriction_Active (No_Dispatching_Calls)
5231            and then not Restriction_Active (No_Select_Statements)
5232          then
5233             Append_To (Result,
5234               Make_Object_Declaration (Loc,
5235                 Defining_Identifier => SSD,
5236                 Aliased_Present     => True,
5237                 Object_Definition   =>
5238                   Make_Subtype_Indication (Loc,
5239                     Subtype_Mark => New_Reference_To (
5240                       RTE (RE_Select_Specific_Data), Loc),
5241                     Constraint   =>
5242                       Make_Index_Or_Discriminant_Constraint (Loc,
5243                         Constraints => New_List (
5244                           Make_Integer_Literal (Loc, Nb_Prim))))));
5245
5246             Append_To (Result,
5247               Make_Attribute_Definition_Clause (Loc,
5248                 Name       => New_Reference_To (SSD, Loc),
5249                 Chars      => Name_Alignment,
5250                 Expression =>
5251                   Make_Attribute_Reference (Loc,
5252                     Prefix =>
5253                       New_Reference_To (RTE (RE_Integer_Address), Loc),
5254                     Attribute_Name => Name_Alignment)));
5255
5256             --  This table is initialized by Make_Select_Specific_Data_Table,
5257             --  which calls Set_Entry_Index and Set_Prim_Op_Kind.
5258
5259             Append_To (TSD_Aggr_List,
5260               Make_Attribute_Reference (Loc,
5261                 Prefix => New_Reference_To (SSD, Loc),
5262                 Attribute_Name => Name_Unchecked_Access));
5263          else
5264             Append_To (TSD_Aggr_List, Make_Null (Loc));
5265          end if;
5266       end if;
5267
5268       --  Initialize the table of ancestor tags. In case of interface types
5269       --  this table is not needed.
5270
5271       TSD_Tags_List := New_List;
5272
5273       --  If we are not statically allocating the dispatch table then we must
5274       --  fill position 0 with null because we still have not generated the
5275       --  tag of Typ.
5276
5277       if not Building_Static_DT (Typ)
5278         or else Is_Interface (Typ)
5279       then
5280          Append_To (TSD_Tags_List,
5281            Unchecked_Convert_To (RTE (RE_Tag),
5282              New_Reference_To (RTE (RE_Null_Address), Loc)));
5283
5284       --  Otherwise we can safely reference the tag
5285
5286       else
5287          Append_To (TSD_Tags_List,
5288            New_Reference_To (DT_Ptr, Loc));
5289       end if;
5290
5291       --  Fill the rest of the table with the tags of the ancestors
5292
5293       declare
5294          Current_Typ : Entity_Id;
5295          Parent_Typ  : Entity_Id;
5296          Pos         : Nat;
5297
5298       begin
5299          Pos := 1;
5300          Current_Typ := Typ;
5301
5302          loop
5303             Parent_Typ := Etype (Current_Typ);
5304
5305             if Is_Private_Type (Parent_Typ) then
5306                Parent_Typ := Full_View (Base_Type (Parent_Typ));
5307             end if;
5308
5309             exit when Parent_Typ = Current_Typ;
5310
5311             if Is_CPP_Class (Parent_Typ) then
5312
5313                --  The tags defined in the C++ side will be inherited when
5314                --  the object is constructed (Exp_Ch3.Build_Init_Procedure)
5315
5316                Append_To (TSD_Tags_List,
5317                  Unchecked_Convert_To (RTE (RE_Tag),
5318                    New_Reference_To (RTE (RE_Null_Address), Loc)));
5319             else
5320                Append_To (TSD_Tags_List,
5321                  New_Reference_To
5322                    (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
5323                     Loc));
5324             end if;
5325
5326             Pos := Pos + 1;
5327             Current_Typ := Parent_Typ;
5328          end loop;
5329
5330          pragma Assert (Pos = I_Depth + 1);
5331       end;
5332
5333       Append_To (TSD_Aggr_List,
5334         Make_Aggregate (Loc,
5335           Expressions => TSD_Tags_List));
5336
5337       --  Build the TSD object
5338
5339       Append_To (Result,
5340         Make_Object_Declaration (Loc,
5341           Defining_Identifier => TSD,
5342           Aliased_Present     => True,
5343           Constant_Present    => Building_Static_DT (Typ),
5344           Object_Definition   =>
5345             Make_Subtype_Indication (Loc,
5346               Subtype_Mark => New_Reference_To (
5347                 RTE (RE_Type_Specific_Data), Loc),
5348               Constraint =>
5349                 Make_Index_Or_Discriminant_Constraint (Loc,
5350                   Constraints => New_List (
5351                     Make_Integer_Literal (Loc, I_Depth)))),
5352
5353           Expression => Make_Aggregate (Loc,
5354             Expressions => TSD_Aggr_List)));
5355
5356       Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
5357
5358       Append_To (Result,
5359         Make_Attribute_Definition_Clause (Loc,
5360           Name       => New_Reference_To (TSD, Loc),
5361           Chars      => Name_Alignment,
5362           Expression =>
5363             Make_Attribute_Reference (Loc,
5364               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
5365               Attribute_Name => Name_Alignment)));
5366
5367       --  Initialize or declare the dispatch table object
5368
5369       if not Has_DT (Typ) then
5370          DT_Constr_List := New_List;
5371          DT_Aggr_List   := New_List;
5372
5373          --  Typeinfo
5374
5375          New_Node :=
5376            Make_Attribute_Reference (Loc,
5377              Prefix => New_Reference_To (TSD, Loc),
5378              Attribute_Name => Name_Address);
5379
5380          Append_To (DT_Constr_List, New_Node);
5381          Append_To (DT_Aggr_List,   New_Copy (New_Node));
5382          Append_To (DT_Aggr_List,   Make_Integer_Literal (Loc, 0));
5383
5384          --  In case of locally defined tagged types we have already declared
5385          --  and uninitialized object for the dispatch table, which is now
5386          --  initialized by means of the following assignment:
5387
5388          --    DT := (TSD'Address, 0);
5389
5390          if not Building_Static_DT (Typ) then
5391             Append_To (Result,
5392               Make_Assignment_Statement (Loc,
5393                 Name => New_Reference_To (DT, Loc),
5394                 Expression => Make_Aggregate (Loc,
5395                   Expressions => DT_Aggr_List)));
5396
5397          --  In case of library level tagged types we declare and export now
5398          --  the constant object containing the dummy dispatch table. There
5399          --  is no need to declare the tag here because it has been previously
5400          --  declared by Make_Tags
5401
5402          --   DT : aliased constant No_Dispatch_Table :=
5403          --          (NDT_TSD       => TSD'Address;
5404          --           NDT_Prims_Ptr => 0);
5405          --   for DT'Alignment use Address'Alignment;
5406
5407          else
5408             Append_To (Result,
5409               Make_Object_Declaration (Loc,
5410                 Defining_Identifier => DT,
5411                 Aliased_Present     => True,
5412                 Constant_Present    => True,
5413                 Object_Definition   =>
5414                   New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
5415                 Expression => Make_Aggregate (Loc,
5416                   Expressions => DT_Aggr_List)));
5417
5418             Append_To (Result,
5419               Make_Attribute_Definition_Clause (Loc,
5420                 Name       => New_Reference_To (DT, Loc),
5421                 Chars      => Name_Alignment,
5422                 Expression =>
5423                   Make_Attribute_Reference (Loc,
5424                     Prefix =>
5425                       New_Reference_To (RTE (RE_Integer_Address), Loc),
5426                     Attribute_Name => Name_Alignment)));
5427
5428             Export_DT (Typ, DT);
5429          end if;
5430
5431       --  Common case: Typ has a dispatch table
5432
5433       --  Generate:
5434
5435       --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
5436       --                    (predef-prim-op-1'address,
5437       --                     predef-prim-op-2'address,
5438       --                     ...
5439       --                     predef-prim-op-n'address);
5440       --   for Predef_Prims'Alignment use Address'Alignment
5441
5442       --   DT : Dispatch_Table (Nb_Prims) :=
5443       --          (Signature => <sig-value>,
5444       --           Tag_Kind  => <tag_kind-value>,
5445       --           Predef_Prims => Predef_Prims'First'Address,
5446       --           Offset_To_Top => 0,
5447       --           TSD           => TSD'Address;
5448       --           Prims_Ptr     => (prim-op-1'address,
5449       --                             prim-op-2'address,
5450       --                             ...
5451       --                             prim-op-n'address));
5452       --   for DT'Alignment use Address'Alignment
5453
5454       else
5455          declare
5456             Pos : Nat;
5457
5458          begin
5459             if not Building_Static_DT (Typ) then
5460                Nb_Predef_Prims := Max_Predef_Prims;
5461
5462             else
5463                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5464                while Present (Prim_Elmt) loop
5465                   Prim := Node (Prim_Elmt);
5466
5467                   if Is_Predefined_Dispatching_Operation (Prim)
5468                     and then not Is_Abstract_Subprogram (Prim)
5469                   then
5470                      Pos := UI_To_Int (DT_Position (Prim));
5471
5472                      if Pos > Nb_Predef_Prims then
5473                         Nb_Predef_Prims := Pos;
5474                      end if;
5475                   end if;
5476
5477                   Next_Elmt (Prim_Elmt);
5478                end loop;
5479             end if;
5480
5481             declare
5482                Prim_Table : array
5483                               (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
5484                Decl       : Node_Id;
5485                E          : Entity_Id;
5486
5487             begin
5488                Prim_Ops_Aggr_List := New_List;
5489
5490                Prim_Table := (others => Empty);
5491
5492                if Building_Static_DT (Typ) then
5493                   Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
5494                   while Present (Prim_Elmt) loop
5495                      Prim := Node (Prim_Elmt);
5496
5497                      if Is_Predefined_Dispatching_Operation (Prim)
5498                        and then not Is_Abstract_Subprogram (Prim)
5499                        and then not Is_Eliminated (Prim)
5500                        and then not Present (Prim_Table
5501                                               (UI_To_Int (DT_Position (Prim))))
5502                      then
5503                         E := Ultimate_Alias (Prim);
5504                         pragma Assert (not Is_Abstract_Subprogram (E));
5505                         Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5506                      end if;
5507
5508                      Next_Elmt (Prim_Elmt);
5509                   end loop;
5510                end if;
5511
5512                for J in Prim_Table'Range loop
5513                   if Present (Prim_Table (J)) then
5514                      New_Node :=
5515                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5516                          Make_Attribute_Reference (Loc,
5517                            Prefix => New_Reference_To (Prim_Table (J), Loc),
5518                            Attribute_Name => Name_Unrestricted_Access));
5519                   else
5520                      New_Node := Make_Null (Loc);
5521                   end if;
5522
5523                   Append_To (Prim_Ops_Aggr_List, New_Node);
5524                end loop;
5525
5526                New_Node :=
5527                  Make_Aggregate (Loc,
5528                    Expressions => Prim_Ops_Aggr_List);
5529
5530                Decl :=
5531                  Make_Subtype_Declaration (Loc,
5532                    Defining_Identifier => Make_Temporary (Loc, 'S'),
5533                    Subtype_Indication  =>
5534                      New_Reference_To (RTE (RE_Address_Array), Loc));
5535
5536                Append_To (Result, Decl);
5537
5538                Append_To (Result,
5539                  Make_Object_Declaration (Loc,
5540                    Defining_Identifier => Predef_Prims,
5541                    Aliased_Present     => True,
5542                    Constant_Present    => Building_Static_DT (Typ),
5543                    Object_Definition   => New_Reference_To
5544                                            (Defining_Identifier (Decl), Loc),
5545                    Expression => New_Node));
5546
5547                --  Remember aggregates initializing dispatch tables
5548
5549                Append_Elmt (New_Node, DT_Aggr);
5550
5551                Append_To (Result,
5552                  Make_Attribute_Definition_Clause (Loc,
5553                    Name       => New_Reference_To (Predef_Prims, Loc),
5554                    Chars      => Name_Alignment,
5555                    Expression =>
5556                      Make_Attribute_Reference (Loc,
5557                        Prefix =>
5558                          New_Reference_To (RTE (RE_Integer_Address), Loc),
5559                        Attribute_Name => Name_Alignment)));
5560             end;
5561          end;
5562
5563          --  Stage 1: Initialize the discriminant and the record components
5564
5565          DT_Constr_List := New_List;
5566          DT_Aggr_List   := New_List;
5567
5568          --  Num_Prims. If the tagged type has no primitives we add a dummy
5569          --  slot whose address will be the tag of this type.
5570
5571          if Nb_Prim = 0 then
5572             New_Node := Make_Integer_Literal (Loc, 1);
5573          else
5574             New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5575          end if;
5576
5577          Append_To (DT_Constr_List, New_Node);
5578          Append_To (DT_Aggr_List,   New_Copy (New_Node));
5579
5580          --  Signature
5581
5582          if RTE_Record_Component_Available (RE_Signature) then
5583             Append_To (DT_Aggr_List,
5584               New_Reference_To (RTE (RE_Primary_DT), Loc));
5585          end if;
5586
5587          --  Tag_Kind
5588
5589          if RTE_Record_Component_Available (RE_Tag_Kind) then
5590             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
5591          end if;
5592
5593          --  Predef_Prims
5594
5595          Append_To (DT_Aggr_List,
5596            Make_Attribute_Reference (Loc,
5597              Prefix => New_Reference_To (Predef_Prims, Loc),
5598              Attribute_Name => Name_Address));
5599
5600          --  Offset_To_Top
5601
5602          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5603
5604          --  Typeinfo
5605
5606          Append_To (DT_Aggr_List,
5607            Make_Attribute_Reference (Loc,
5608              Prefix => New_Reference_To (TSD, Loc),
5609              Attribute_Name => Name_Address));
5610
5611          --  Stage 2: Initialize the table of primitive operations
5612
5613          Prim_Ops_Aggr_List := New_List;
5614
5615          if Nb_Prim = 0 then
5616             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5617
5618          elsif not Building_Static_DT (Typ) then
5619             for J in 1 .. Nb_Prim loop
5620                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5621             end loop;
5622
5623          else
5624             declare
5625                CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
5626                E            : Entity_Id;
5627                Prim         : Entity_Id;
5628                Prim_Elmt    : Elmt_Id;
5629                Prim_Pos     : Nat;
5630                Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
5631
5632             begin
5633                Prim_Table := (others => Empty);
5634
5635                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5636                while Present (Prim_Elmt) loop
5637                   Prim := Node (Prim_Elmt);
5638
5639                   --  Retrieve the ultimate alias of the primitive for proper
5640                   --  handling of renamings and eliminated primitives.
5641
5642                   E        := Ultimate_Alias (Prim);
5643                   Prim_Pos := UI_To_Int (DT_Position (E));
5644
5645                   --  Do not reference predefined primitives because they are
5646                   --  located in a separate dispatch table; skip entities with
5647                   --  attribute Interface_Alias because they are only required
5648                   --  to build secondary dispatch tables; skip abstract and
5649                   --  eliminated primitives; for derivations of CPP types skip
5650                   --  primitives located in the C++ part of the dispatch table
5651                   --  because their slot is initialized by the IC routine.
5652
5653                   if not Is_Predefined_Dispatching_Operation (Prim)
5654                     and then not Is_Predefined_Dispatching_Operation (E)
5655                     and then not Present (Interface_Alias (Prim))
5656                     and then not Is_Abstract_Subprogram (E)
5657                     and then not Is_Eliminated (E)
5658                     and then (not Is_CPP_Class (Root_Type (Typ))
5659                                or else Prim_Pos > CPP_Nb_Prims)
5660                   then
5661                      pragma Assert
5662                        (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
5663
5664                      Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5665                   end if;
5666
5667                   Next_Elmt (Prim_Elmt);
5668                end loop;
5669
5670                for J in Prim_Table'Range loop
5671                   if Present (Prim_Table (J)) then
5672                      New_Node :=
5673                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5674                          Make_Attribute_Reference (Loc,
5675                            Prefix => New_Reference_To (Prim_Table (J), Loc),
5676                            Attribute_Name => Name_Unrestricted_Access));
5677                   else
5678                      New_Node := Make_Null (Loc);
5679                   end if;
5680
5681                   Append_To (Prim_Ops_Aggr_List, New_Node);
5682                end loop;
5683             end;
5684          end if;
5685
5686          New_Node :=
5687            Make_Aggregate (Loc,
5688              Expressions => Prim_Ops_Aggr_List);
5689
5690          Append_To (DT_Aggr_List, New_Node);
5691
5692          --  Remember aggregates initializing dispatch tables
5693
5694          Append_Elmt (New_Node, DT_Aggr);
5695
5696          --  In case of locally defined tagged types we have already declared
5697          --  and uninitialized object for the dispatch table, which is now
5698          --  initialized by means of an assignment.
5699
5700          if not Building_Static_DT (Typ) then
5701             Append_To (Result,
5702               Make_Assignment_Statement (Loc,
5703                 Name => New_Reference_To (DT, Loc),
5704                 Expression => Make_Aggregate (Loc,
5705                   Expressions => DT_Aggr_List)));
5706
5707          --  In case of library level tagged types we declare now and export
5708          --  the constant object containing the dispatch table.
5709
5710          else
5711             Append_To (Result,
5712               Make_Object_Declaration (Loc,
5713                 Defining_Identifier => DT,
5714                 Aliased_Present     => True,
5715                 Constant_Present    => True,
5716                 Object_Definition   =>
5717                   Make_Subtype_Indication (Loc,
5718                     Subtype_Mark => New_Reference_To
5719                                       (RTE (RE_Dispatch_Table_Wrapper), Loc),
5720                     Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
5721                                       Constraints => DT_Constr_List)),
5722                 Expression => Make_Aggregate (Loc,
5723                   Expressions => DT_Aggr_List)));
5724
5725             Append_To (Result,
5726               Make_Attribute_Definition_Clause (Loc,
5727                 Name       => New_Reference_To (DT, Loc),
5728                 Chars      => Name_Alignment,
5729                 Expression =>
5730                   Make_Attribute_Reference (Loc,
5731                     Prefix =>
5732                       New_Reference_To (RTE (RE_Integer_Address), Loc),
5733                     Attribute_Name => Name_Alignment)));
5734
5735             Export_DT (Typ, DT);
5736          end if;
5737       end if;
5738
5739       --  Initialize the table of ancestor tags if not building static
5740       --  dispatch table
5741
5742       if not Building_Static_DT (Typ)
5743         and then not Is_Interface (Typ)
5744         and then not Is_CPP_Class (Typ)
5745       then
5746          Append_To (Result,
5747            Make_Assignment_Statement (Loc,
5748              Name =>
5749                Make_Indexed_Component (Loc,
5750                  Prefix =>
5751                    Make_Selected_Component (Loc,
5752                      Prefix =>
5753                        New_Reference_To (TSD, Loc),
5754                      Selector_Name =>
5755                        New_Reference_To
5756                          (RTE_Record_Component (RE_Tags_Table), Loc)),
5757                  Expressions =>
5758                     New_List (Make_Integer_Literal (Loc, 0))),
5759
5760              Expression =>
5761                New_Reference_To
5762                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
5763       end if;
5764
5765       --  Inherit the dispatch tables of the parent. There is no need to
5766       --  inherit anything from the parent when building static dispatch tables
5767       --  because the whole dispatch table (including inherited primitives) has
5768       --  been already built.
5769
5770       if Building_Static_DT (Typ) then
5771          null;
5772
5773       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
5774       --  in the init proc, and we don't need to fill them in here.
5775
5776       elsif Is_CPP_Class (Parent_Typ) then
5777          null;
5778
5779       --  Otherwise we fill in the dispatch tables here
5780
5781       else
5782          if Typ /= Parent_Typ
5783            and then not Is_Interface (Typ)
5784            and then not Restriction_Active (No_Dispatching_Calls)
5785          then
5786             --  Inherit the dispatch table
5787
5788             if not Is_Interface (Typ)
5789               and then not Is_Interface (Parent_Typ)
5790               and then not Is_CPP_Class (Parent_Typ)
5791             then
5792                declare
5793                   Nb_Prims : constant Int :=
5794                                UI_To_Int (DT_Entry_Count
5795                                  (First_Tag_Component (Parent_Typ)));
5796
5797                begin
5798                   Append_To (Elab_Code,
5799                     Build_Inherit_Predefined_Prims (Loc,
5800                       Old_Tag_Node =>
5801                         New_Reference_To
5802                           (Node
5803                            (Next_Elmt
5804                             (First_Elmt
5805                              (Access_Disp_Table (Parent_Typ)))), Loc),
5806                       New_Tag_Node =>
5807                         New_Reference_To
5808                           (Node
5809                            (Next_Elmt
5810                             (First_Elmt
5811                              (Access_Disp_Table (Typ)))), Loc)));
5812
5813                   if Nb_Prims /= 0 then
5814                      Append_To (Elab_Code,
5815                        Build_Inherit_Prims (Loc,
5816                          Typ          => Typ,
5817                          Old_Tag_Node =>
5818                            New_Reference_To
5819                              (Node
5820                               (First_Elmt
5821                                (Access_Disp_Table (Parent_Typ))), Loc),
5822                          New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
5823                          Num_Prims    => Nb_Prims));
5824                   end if;
5825                end;
5826             end if;
5827
5828             --  Inherit the secondary dispatch tables of the ancestor
5829
5830             if not Is_CPP_Class (Parent_Typ) then
5831                declare
5832                   Sec_DT_Ancestor : Elmt_Id :=
5833                                       Next_Elmt
5834                                        (Next_Elmt
5835                                         (First_Elmt
5836                                           (Access_Disp_Table (Parent_Typ))));
5837                   Sec_DT_Typ      : Elmt_Id :=
5838                                       Next_Elmt
5839                                        (Next_Elmt
5840                                          (First_Elmt
5841                                            (Access_Disp_Table (Typ))));
5842
5843                   procedure Copy_Secondary_DTs (Typ : Entity_Id);
5844                   --  Local procedure required to climb through the ancestors
5845                   --  and copy the contents of all their secondary dispatch
5846                   --  tables.
5847
5848                   ------------------------
5849                   -- Copy_Secondary_DTs --
5850                   ------------------------
5851
5852                   procedure Copy_Secondary_DTs (Typ : Entity_Id) is
5853                      E     : Entity_Id;
5854                      Iface : Elmt_Id;
5855
5856                   begin
5857                      --  Climb to the ancestor (if any) handling private types
5858
5859                      if Present (Full_View (Etype (Typ))) then
5860                         if Full_View (Etype (Typ)) /= Typ then
5861                            Copy_Secondary_DTs (Full_View (Etype (Typ)));
5862                         end if;
5863
5864                      elsif Etype (Typ) /= Typ then
5865                         Copy_Secondary_DTs (Etype (Typ));
5866                      end if;
5867
5868                      if Present (Interfaces (Typ))
5869                        and then not Is_Empty_Elmt_List (Interfaces (Typ))
5870                      then
5871                         Iface := First_Elmt (Interfaces (Typ));
5872                         E     := First_Entity (Typ);
5873                         while Present (E)
5874                           and then Present (Node (Sec_DT_Ancestor))
5875                           and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
5876                         loop
5877                            if Is_Tag (E) and then Chars (E) /= Name_uTag then
5878                               declare
5879                                  Num_Prims : constant Int :=
5880                                                UI_To_Int (DT_Entry_Count (E));
5881
5882                               begin
5883                                  if not Is_Interface (Etype (Typ)) then
5884
5885                                     --  Inherit first secondary dispatch table
5886
5887                                     Append_To (Elab_Code,
5888                                       Build_Inherit_Predefined_Prims (Loc,
5889                                         Old_Tag_Node =>
5890                                           Unchecked_Convert_To (RTE (RE_Tag),
5891                                             New_Reference_To
5892                                               (Node
5893                                                 (Next_Elmt (Sec_DT_Ancestor)),
5894                                                Loc)),
5895                                         New_Tag_Node =>
5896                                           Unchecked_Convert_To (RTE (RE_Tag),
5897                                             New_Reference_To
5898                                               (Node (Next_Elmt (Sec_DT_Typ)),
5899                                                Loc))));
5900
5901                                     if Num_Prims /= 0 then
5902                                        Append_To (Elab_Code,
5903                                          Build_Inherit_Prims (Loc,
5904                                            Typ          => Node (Iface),
5905                                            Old_Tag_Node =>
5906                                              Unchecked_Convert_To
5907                                                (RTE (RE_Tag),
5908                                                 New_Reference_To
5909                                                   (Node (Sec_DT_Ancestor),
5910                                                    Loc)),
5911                                            New_Tag_Node =>
5912                                              Unchecked_Convert_To
5913                                               (RTE (RE_Tag),
5914                                                New_Reference_To
5915                                                  (Node (Sec_DT_Typ), Loc)),
5916                                            Num_Prims    => Num_Prims));
5917                                     end if;
5918                                  end if;
5919
5920                                  Next_Elmt (Sec_DT_Ancestor);
5921                                  Next_Elmt (Sec_DT_Typ);
5922
5923                                  --  Skip the secondary dispatch table of
5924                                  --  predefined primitives
5925
5926                                  Next_Elmt (Sec_DT_Ancestor);
5927                                  Next_Elmt (Sec_DT_Typ);
5928
5929                                  if not Is_Interface (Etype (Typ)) then
5930
5931                                     --  Inherit second secondary dispatch table
5932
5933                                     Append_To (Elab_Code,
5934                                       Build_Inherit_Predefined_Prims (Loc,
5935                                         Old_Tag_Node =>
5936                                           Unchecked_Convert_To (RTE (RE_Tag),
5937                                              New_Reference_To
5938                                                (Node
5939                                                  (Next_Elmt (Sec_DT_Ancestor)),
5940                                                 Loc)),
5941                                         New_Tag_Node =>
5942                                           Unchecked_Convert_To (RTE (RE_Tag),
5943                                             New_Reference_To
5944                                               (Node (Next_Elmt (Sec_DT_Typ)),
5945                                                Loc))));
5946
5947                                     if Num_Prims /= 0 then
5948                                        Append_To (Elab_Code,
5949                                          Build_Inherit_Prims (Loc,
5950                                            Typ          => Node (Iface),
5951                                            Old_Tag_Node =>
5952                                              Unchecked_Convert_To
5953                                                (RTE (RE_Tag),
5954                                                 New_Reference_To
5955                                                   (Node (Sec_DT_Ancestor),
5956                                                    Loc)),
5957                                            New_Tag_Node =>
5958                                              Unchecked_Convert_To
5959                                               (RTE (RE_Tag),
5960                                                New_Reference_To
5961                                                  (Node (Sec_DT_Typ), Loc)),
5962                                            Num_Prims    => Num_Prims));
5963                                     end if;
5964                                  end if;
5965                               end;
5966
5967                               Next_Elmt (Sec_DT_Ancestor);
5968                               Next_Elmt (Sec_DT_Typ);
5969
5970                               --  Skip the secondary dispatch table of
5971                               --  predefined primitives
5972
5973                               Next_Elmt (Sec_DT_Ancestor);
5974                               Next_Elmt (Sec_DT_Typ);
5975
5976                               Next_Elmt (Iface);
5977                            end if;
5978
5979                            Next_Entity (E);
5980                         end loop;
5981                      end if;
5982                   end Copy_Secondary_DTs;
5983
5984                begin
5985                   if Present (Node (Sec_DT_Ancestor))
5986                     and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
5987                   then
5988                      --  Handle private types
5989
5990                      if Present (Full_View (Typ)) then
5991                         Copy_Secondary_DTs (Full_View (Typ));
5992                      else
5993                         Copy_Secondary_DTs (Typ);
5994                      end if;
5995                   end if;
5996                end;
5997             end if;
5998          end if;
5999       end if;
6000
6001       --  Generate code to register the Tag in the External_Tag hash table for
6002       --  the pure Ada type only.
6003
6004       --        Register_Tag (Dt_Ptr);
6005
6006       --  Skip this action in the following cases:
6007       --    1) if Register_Tag is not available.
6008       --    2) in No_Run_Time mode.
6009       --    3) if Typ is not defined at the library level (this is required
6010       --       to avoid adding concurrency control to the hash table used
6011       --       by the run-time to register the tags).
6012
6013       if not No_Run_Time_Mode
6014         and then Is_Library_Level_Entity (Typ)
6015         and then RTE_Available (RE_Register_Tag)
6016       then
6017          Append_To (Elab_Code,
6018            Make_Procedure_Call_Statement (Loc,
6019              Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
6020              Parameter_Associations =>
6021                New_List (New_Reference_To (DT_Ptr, Loc))));
6022       end if;
6023
6024       if not Is_Empty_List (Elab_Code) then
6025          Append_List_To (Result, Elab_Code);
6026       end if;
6027
6028       --  Populate the two auxiliary tables used for dispatching asynchronous,
6029       --  conditional and timed selects for synchronized types that implement
6030       --  a limited interface. Skip this step in Ravenscar profile or when
6031       --  general dispatching is forbidden.
6032
6033       if Ada_Version >= Ada_05
6034         and then Is_Concurrent_Record_Type (Typ)
6035         and then Has_Interfaces (Typ)
6036         and then not Restriction_Active (No_Dispatching_Calls)
6037         and then not Restriction_Active (No_Select_Statements)
6038       then
6039          Append_List_To (Result,
6040            Make_Select_Specific_Data_Table (Typ));
6041       end if;
6042
6043       --  Remember entities containing dispatch tables
6044
6045       Append_Elmt (Predef_Prims, DT_Decl);
6046       Append_Elmt (DT, DT_Decl);
6047
6048       Analyze_List (Result, Suppress => All_Checks);
6049       Set_Has_Dispatch_Table (Typ);
6050
6051       --  Mark entities containing dispatch tables. Required by the backend to
6052       --  handle them properly.
6053
6054       if Has_DT (Typ) then
6055          declare
6056             Elmt : Elmt_Id;
6057
6058          begin
6059             --  Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
6060             --  the decoration required by the backend
6061
6062             Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
6063             Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
6064
6065             --  Object declarations
6066
6067             Elmt := First_Elmt (DT_Decl);
6068             while Present (Elmt) loop
6069                Set_Is_Dispatch_Table_Entity (Node (Elmt));
6070                pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
6071                  or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
6072                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6073                Next_Elmt (Elmt);
6074             end loop;
6075
6076             --  Aggregates initializing dispatch tables
6077
6078             Elmt := First_Elmt (DT_Aggr);
6079             while Present (Elmt) loop
6080                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
6081                Next_Elmt (Elmt);
6082             end loop;
6083          end;
6084       end if;
6085
6086       --  Register the tagged type in the call graph nodes table
6087
6088       Register_CG_Node (Typ);
6089
6090       return Result;
6091    end Make_DT;
6092
6093    -------------------------------------
6094    -- Make_Select_Specific_Data_Table --
6095    -------------------------------------
6096
6097    function Make_Select_Specific_Data_Table
6098      (Typ : Entity_Id) return List_Id
6099    is
6100       Assignments : constant List_Id    := New_List;
6101       Loc         : constant Source_Ptr := Sloc (Typ);
6102
6103       Conc_Typ  : Entity_Id;
6104       Decls     : List_Id;
6105       DT_Ptr    : Entity_Id;
6106       Prim      : Entity_Id;
6107       Prim_Als  : Entity_Id;
6108       Prim_Elmt : Elmt_Id;
6109       Prim_Pos  : Uint;
6110       Nb_Prim   : Nat := 0;
6111
6112       type Examined_Array is array (Int range <>) of Boolean;
6113
6114       function Find_Entry_Index (E : Entity_Id) return Uint;
6115       --  Given an entry, find its index in the visible declarations of the
6116       --  corresponding concurrent type of Typ.
6117
6118       ----------------------
6119       -- Find_Entry_Index --
6120       ----------------------
6121
6122       function Find_Entry_Index (E : Entity_Id) return Uint is
6123          Index     : Uint := Uint_1;
6124          Subp_Decl : Entity_Id;
6125
6126       begin
6127          if Present (Decls)
6128            and then not Is_Empty_List (Decls)
6129          then
6130             Subp_Decl := First (Decls);
6131             while Present (Subp_Decl) loop
6132                if Nkind (Subp_Decl) = N_Entry_Declaration then
6133                   if Defining_Identifier (Subp_Decl) = E then
6134                      return Index;
6135                   end if;
6136
6137                   Index := Index + 1;
6138                end if;
6139
6140                Next (Subp_Decl);
6141             end loop;
6142          end if;
6143
6144          return Uint_0;
6145       end Find_Entry_Index;
6146
6147    --  Start of processing for Make_Select_Specific_Data_Table
6148
6149    begin
6150       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6151
6152       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
6153
6154       if Present (Corresponding_Concurrent_Type (Typ)) then
6155          Conc_Typ := Corresponding_Concurrent_Type (Typ);
6156
6157          if Present (Full_View (Conc_Typ)) then
6158             Conc_Typ := Full_View (Conc_Typ);
6159          end if;
6160
6161          if Ekind (Conc_Typ) = E_Protected_Type then
6162             Decls := Visible_Declarations (Protected_Definition (
6163                        Parent (Conc_Typ)));
6164          else
6165             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
6166             Decls := Visible_Declarations (Task_Definition (
6167                        Parent (Conc_Typ)));
6168          end if;
6169       end if;
6170
6171       --  Count the non-predefined primitive operations
6172
6173       Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6174       while Present (Prim_Elmt) loop
6175          Prim := Node (Prim_Elmt);
6176
6177          if not (Is_Predefined_Dispatching_Operation (Prim)
6178                    or else Is_Predefined_Dispatching_Alias (Prim))
6179          then
6180             Nb_Prim := Nb_Prim + 1;
6181          end if;
6182
6183          Next_Elmt (Prim_Elmt);
6184       end loop;
6185
6186       declare
6187          Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
6188
6189       begin
6190          Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6191          while Present (Prim_Elmt) loop
6192             Prim := Node (Prim_Elmt);
6193
6194             --  Look for primitive overriding an abstract interface subprogram
6195
6196             if Present (Interface_Alias (Prim))
6197               and then not
6198                 Is_Ancestor
6199                   (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
6200               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
6201             then
6202                Prim_Pos := DT_Position (Alias (Prim));
6203                pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
6204                Examined (UI_To_Int (Prim_Pos)) := True;
6205
6206                --  Set the primitive operation kind regardless of subprogram
6207                --  type. Generate:
6208                --    Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
6209
6210                Append_To (Assignments,
6211                  Make_Procedure_Call_Statement (Loc,
6212                    Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
6213                    Parameter_Associations => New_List (
6214                      New_Reference_To (DT_Ptr, Loc),
6215                      Make_Integer_Literal (Loc, Prim_Pos),
6216                      Prim_Op_Kind (Alias (Prim), Typ))));
6217
6218                --  Retrieve the root of the alias chain
6219
6220                Prim_Als := Ultimate_Alias (Prim);
6221
6222                --  In the case of an entry wrapper, set the entry index
6223
6224                if Ekind (Prim) = E_Procedure
6225                  and then Is_Primitive_Wrapper (Prim_Als)
6226                  and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
6227                then
6228                   --  Generate:
6229                   --    Ada.Tags.Set_Entry_Index
6230                   --      (DT_Ptr, <position>, <index>);
6231
6232                   Append_To (Assignments,
6233                     Make_Procedure_Call_Statement (Loc,
6234                       Name =>
6235                         New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
6236                       Parameter_Associations => New_List (
6237                         New_Reference_To (DT_Ptr, Loc),
6238                         Make_Integer_Literal (Loc, Prim_Pos),
6239                         Make_Integer_Literal (Loc,
6240                           Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
6241                end if;
6242             end if;
6243
6244             Next_Elmt (Prim_Elmt);
6245          end loop;
6246       end;
6247
6248       return Assignments;
6249    end Make_Select_Specific_Data_Table;
6250
6251    ---------------
6252    -- Make_Tags --
6253    ---------------
6254
6255    function Make_Tags (Typ : Entity_Id) return List_Id is
6256       Loc    : constant Source_Ptr := Sloc (Typ);
6257       Result : constant List_Id    := New_List;
6258
6259       procedure Import_DT
6260         (Tag_Typ         : Entity_Id;
6261          DT              : Entity_Id;
6262          Is_Secondary_DT : Boolean);
6263       --  Import the dispatch table DT of tagged type Tag_Typ. Required to
6264       --  generate forward references and statically allocate the table. For
6265       --  primary dispatch tables that require no dispatch table generate:
6266       --     DT : static aliased constant Non_Dispatch_Table_Wrapper;
6267       --     $pragma import (ada, DT);
6268       --  Otherwise generate:
6269       --     DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
6270       --     $pragma import (ada, DT);
6271
6272       ---------------
6273       -- Import_DT --
6274       ---------------
6275
6276       procedure Import_DT
6277         (Tag_Typ         : Entity_Id;
6278          DT              : Entity_Id;
6279          Is_Secondary_DT : Boolean)
6280       is
6281          DT_Constr_List : List_Id;
6282          Nb_Prim        : Nat;
6283
6284       begin
6285          Set_Is_Imported  (DT);
6286          Set_Ekind        (DT, E_Constant);
6287          Set_Related_Type (DT, Typ);
6288
6289          --  The scope must be set now to call Get_External_Name
6290
6291          Set_Scope (DT, Current_Scope);
6292
6293          Get_External_Name (DT, True);
6294          Set_Interface_Name (DT,
6295            Make_String_Literal (Loc,
6296              Strval => String_From_Name_Buffer));
6297
6298          --  Ensure proper Sprint output of this implicit importation
6299
6300          Set_Is_Internal (DT);
6301
6302          --  Save this entity to allow Make_DT to generate its exportation
6303
6304          Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
6305
6306          --  No dispatch table required
6307
6308          if not Is_Secondary_DT
6309            and then not Has_DT (Tag_Typ)
6310          then
6311             Append_To (Result,
6312               Make_Object_Declaration (Loc,
6313                 Defining_Identifier => DT,
6314                 Aliased_Present     => True,
6315                 Constant_Present    => True,
6316                 Object_Definition   =>
6317                   New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
6318
6319          else
6320             --  Calculate the number of primitives of the dispatch table and
6321             --  the size of the Type_Specific_Data record.
6322
6323             Nb_Prim :=
6324               UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
6325
6326             --  If the tagged type has no primitives we add a dummy slot
6327             --  whose address will be the tag of this type.
6328
6329             if Nb_Prim = 0 then
6330                DT_Constr_List :=
6331                  New_List (Make_Integer_Literal (Loc, 1));
6332             else
6333                DT_Constr_List :=
6334                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
6335             end if;
6336
6337             Append_To (Result,
6338               Make_Object_Declaration (Loc,
6339                 Defining_Identifier => DT,
6340                 Aliased_Present     => True,
6341                 Constant_Present    => True,
6342                 Object_Definition   =>
6343                   Make_Subtype_Indication (Loc,
6344                     Subtype_Mark =>
6345                       New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
6346                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
6347                                     Constraints => DT_Constr_List))));
6348          end if;
6349       end Import_DT;
6350
6351       --  Local variables
6352
6353       Tname            : constant Name_Id := Chars (Typ);
6354       AI_Tag_Comp      : Elmt_Id;
6355       DT               : Node_Id := Empty;
6356       DT_Ptr           : Node_Id;
6357       Predef_Prims_Ptr : Node_Id;
6358       Iface_DT         : Node_Id := Empty;
6359       Iface_DT_Ptr     : Node_Id;
6360       New_Node         : Node_Id;
6361       Suffix_Index     : Int;
6362       Typ_Name         : Name_Id;
6363       Typ_Comps        : Elist_Id;
6364
6365    --  Start of processing for Make_Tags
6366
6367    begin
6368       pragma Assert (No (Access_Disp_Table (Typ)));
6369       Set_Access_Disp_Table (Typ, New_Elmt_List);
6370
6371       --  1) Generate the primary tag entities
6372
6373       --  Primary dispatch table containing user-defined primitives
6374
6375       DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
6376       Set_Etype   (DT_Ptr, RTE (RE_Tag));
6377       Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
6378
6379       --  Minimum decoration
6380
6381       Set_Ekind        (DT_Ptr, E_Variable);
6382       Set_Related_Type (DT_Ptr, Typ);
6383
6384       --  For CPP types there is no need to build the dispatch tables since
6385       --  they are imported from the C++ side. If the CPP type has an IP then
6386       --  we declare now the variable that will store the copy of the C++ tag.
6387       --  If the CPP type is an interface, we need the variable as well,
6388       --  because it becomes the pointer to the corresponding secondary table.
6389
6390       if Is_CPP_Class (Typ) then
6391          if Has_CPP_Constructors (Typ) or else Is_Interface (Typ) then
6392             Append_To (Result,
6393               Make_Object_Declaration (Loc,
6394                 Defining_Identifier => DT_Ptr,
6395                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
6396                 Expression =>
6397                   Unchecked_Convert_To (RTE (RE_Tag),
6398                     New_Reference_To (RTE (RE_Null_Address), Loc))));
6399
6400             Set_Is_Statically_Allocated (DT_Ptr,
6401               Is_Library_Level_Tagged_Type (Typ));
6402          end if;
6403
6404       --  Ada types
6405
6406       else
6407          --  Primary dispatch table containing predefined primitives
6408
6409          Predef_Prims_Ptr :=
6410            Make_Defining_Identifier (Loc,
6411              Chars => New_External_Name (Tname, 'Y'));
6412          Set_Etype   (Predef_Prims_Ptr, RTE (RE_Address));
6413          Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
6414
6415          --  Import the forward declaration of the Dispatch Table wrapper
6416          --  record (Make_DT will take care of its exportation)
6417
6418          if Building_Static_DT (Typ) then
6419             Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
6420
6421             DT :=
6422               Make_Defining_Identifier (Loc,
6423                 Chars => New_External_Name (Tname, 'T'));
6424
6425             Import_DT (Typ, DT, Is_Secondary_DT => False);
6426
6427             if Has_DT (Typ) then
6428                Append_To (Result,
6429                  Make_Object_Declaration (Loc,
6430                    Defining_Identifier => DT_Ptr,
6431                    Constant_Present    => True,
6432                    Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
6433                    Expression =>
6434                      Unchecked_Convert_To (RTE (RE_Tag),
6435                        Make_Attribute_Reference (Loc,
6436                          Prefix =>
6437                            Make_Selected_Component (Loc,
6438                              Prefix => New_Reference_To (DT, Loc),
6439                            Selector_Name =>
6440                              New_Occurrence_Of
6441                                (RTE_Record_Component (RE_Prims_Ptr), Loc)),
6442                          Attribute_Name => Name_Address))));
6443
6444                --  Generate the SCIL node for the previous object declaration
6445                --  because it has a tag initialization.
6446
6447                if Generate_SCIL then
6448                   New_Node :=
6449                     Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
6450                   Set_SCIL_Entity (New_Node, Typ);
6451                   Set_SCIL_Node (Last (Result), New_Node);
6452                end if;
6453
6454                Append_To (Result,
6455                  Make_Object_Declaration (Loc,
6456                    Defining_Identifier => Predef_Prims_Ptr,
6457                    Constant_Present    => True,
6458                    Object_Definition   => New_Reference_To
6459                                                (RTE (RE_Address), Loc),
6460                    Expression =>
6461                      Make_Attribute_Reference (Loc,
6462                        Prefix =>
6463                          Make_Selected_Component (Loc,
6464                            Prefix => New_Reference_To (DT, Loc),
6465                          Selector_Name =>
6466                            New_Occurrence_Of
6467                              (RTE_Record_Component (RE_Predef_Prims), Loc)),
6468                        Attribute_Name => Name_Address)));
6469
6470             --  No dispatch table required
6471
6472             else
6473                Append_To (Result,
6474                  Make_Object_Declaration (Loc,
6475                    Defining_Identifier => DT_Ptr,
6476                    Constant_Present    => True,
6477                    Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
6478                    Expression =>
6479                      Unchecked_Convert_To (RTE (RE_Tag),
6480                        Make_Attribute_Reference (Loc,
6481                          Prefix =>
6482                            Make_Selected_Component (Loc,
6483                              Prefix => New_Reference_To (DT, Loc),
6484                            Selector_Name =>
6485                              New_Occurrence_Of
6486                                (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
6487                          Attribute_Name => Name_Address))));
6488             end if;
6489
6490             Set_Is_True_Constant (DT_Ptr);
6491             Set_Is_Statically_Allocated (DT_Ptr);
6492          end if;
6493       end if;
6494
6495       --  2) Generate the secondary tag entities
6496
6497       --  Collect the components associated with secondary dispatch tables
6498
6499       if Has_Interfaces (Typ) then
6500          Collect_Interface_Components (Typ, Typ_Comps);
6501
6502          --  For each interface type we build an unique external name
6503          --  associated with its secondary dispatch table. This name is used to
6504          --  declare an object that references this secondary dispatch table,
6505          --  value that will be used for the elaboration of Typ's objects and
6506          --  also for the elaboration of objects of derivations of Typ that do
6507          --  not override the primitives of this interface type.
6508
6509          Suffix_Index := 1;
6510
6511          --  Note: The value of Suffix_Index must be in sync with the
6512          --  Suffix_Index values of secondary dispatch tables generated
6513          --  by Make_DT.
6514
6515          if Is_CPP_Class (Typ) then
6516             AI_Tag_Comp := First_Elmt (Typ_Comps);
6517             while Present (AI_Tag_Comp) loop
6518                Get_Secondary_DT_External_Name
6519                  (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
6520                Typ_Name := Name_Find;
6521
6522                --  Declare variables that will store the copy of the C++
6523                --  secondary tags
6524
6525                Iface_DT_Ptr :=
6526                  Make_Defining_Identifier (Loc,
6527                    Chars => New_External_Name (Typ_Name, 'P'));
6528                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6529                Set_Ekind (Iface_DT_Ptr, E_Variable);
6530                Set_Is_Tag (Iface_DT_Ptr);
6531
6532                Set_Has_Thunks (Iface_DT_Ptr);
6533                Set_Related_Type
6534                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6535                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6536
6537                Append_To (Result,
6538                  Make_Object_Declaration (Loc,
6539                    Defining_Identifier => Iface_DT_Ptr,
6540                    Object_Definition   => New_Reference_To
6541                                             (RTE (RE_Interface_Tag), Loc),
6542                    Expression =>
6543                      Unchecked_Convert_To (RTE (RE_Interface_Tag),
6544                        New_Reference_To (RTE (RE_Null_Address), Loc))));
6545
6546                Set_Is_Statically_Allocated (Iface_DT_Ptr,
6547                  Is_Library_Level_Tagged_Type (Typ));
6548
6549                Next_Elmt (AI_Tag_Comp);
6550             end loop;
6551
6552          --  This is not a CPP_Class type
6553
6554          else
6555             AI_Tag_Comp := First_Elmt (Typ_Comps);
6556             while Present (AI_Tag_Comp) loop
6557                Get_Secondary_DT_External_Name
6558                  (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
6559                Typ_Name := Name_Find;
6560
6561                if Building_Static_DT (Typ) then
6562                   Iface_DT :=
6563                     Make_Defining_Identifier (Loc,
6564                       Chars => New_External_Name
6565                                  (Typ_Name, 'T', Suffix_Index => -1));
6566                   Import_DT
6567                     (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
6568                      DT      => Iface_DT,
6569                      Is_Secondary_DT => True);
6570                end if;
6571
6572                --  Secondary dispatch table referencing thunks to user-defined
6573                --  primitives covered by this interface.
6574
6575                Iface_DT_Ptr :=
6576                  Make_Defining_Identifier (Loc,
6577                    Chars => New_External_Name (Typ_Name, 'P'));
6578                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6579                Set_Ekind (Iface_DT_Ptr, E_Constant);
6580                Set_Is_Tag (Iface_DT_Ptr);
6581                Set_Has_Thunks (Iface_DT_Ptr);
6582                Set_Is_Statically_Allocated (Iface_DT_Ptr,
6583                  Is_Library_Level_Tagged_Type (Typ));
6584                Set_Is_True_Constant (Iface_DT_Ptr);
6585                Set_Related_Type
6586                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6587                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6588
6589                if Building_Static_DT (Typ) then
6590                   Append_To (Result,
6591                     Make_Object_Declaration (Loc,
6592                       Defining_Identifier => Iface_DT_Ptr,
6593                       Constant_Present    => True,
6594                       Object_Definition   => New_Reference_To
6595                                                (RTE (RE_Interface_Tag), Loc),
6596                       Expression =>
6597                         Unchecked_Convert_To (RTE (RE_Interface_Tag),
6598                           Make_Attribute_Reference (Loc,
6599                             Prefix =>
6600                               Make_Selected_Component (Loc,
6601                                 Prefix => New_Reference_To (Iface_DT, Loc),
6602                               Selector_Name =>
6603                                 New_Occurrence_Of
6604                                   (RTE_Record_Component (RE_Prims_Ptr), Loc)),
6605                             Attribute_Name => Name_Address))));
6606                end if;
6607
6608                --  Secondary dispatch table referencing thunks to predefined
6609                --  primitives.
6610
6611                Iface_DT_Ptr :=
6612                  Make_Defining_Identifier (Loc,
6613                    Chars => New_External_Name (Typ_Name, 'Y'));
6614                Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
6615                Set_Ekind (Iface_DT_Ptr, E_Constant);
6616                Set_Is_Tag (Iface_DT_Ptr);
6617                Set_Has_Thunks (Iface_DT_Ptr);
6618                Set_Is_Statically_Allocated (Iface_DT_Ptr,
6619                  Is_Library_Level_Tagged_Type (Typ));
6620                Set_Is_True_Constant (Iface_DT_Ptr);
6621                Set_Related_Type
6622                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6623                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6624
6625                --  Secondary dispatch table referencing user-defined primitives
6626                --  covered by this interface.
6627
6628                Iface_DT_Ptr :=
6629                  Make_Defining_Identifier (Loc,
6630                    Chars => New_External_Name (Typ_Name, 'D'));
6631                Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6632                Set_Ekind (Iface_DT_Ptr, E_Constant);
6633                Set_Is_Tag (Iface_DT_Ptr);
6634                Set_Is_Statically_Allocated (Iface_DT_Ptr,
6635                  Is_Library_Level_Tagged_Type (Typ));
6636                Set_Is_True_Constant (Iface_DT_Ptr);
6637                Set_Related_Type
6638                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6639                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6640
6641                --  Secondary dispatch table referencing predefined primitives
6642
6643                Iface_DT_Ptr :=
6644                  Make_Defining_Identifier (Loc,
6645                    Chars => New_External_Name (Typ_Name, 'Z'));
6646                Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
6647                Set_Ekind (Iface_DT_Ptr, E_Constant);
6648                Set_Is_Tag (Iface_DT_Ptr);
6649                Set_Is_Statically_Allocated (Iface_DT_Ptr,
6650                  Is_Library_Level_Tagged_Type (Typ));
6651                Set_Is_True_Constant (Iface_DT_Ptr);
6652                Set_Related_Type
6653                  (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6654                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6655
6656                Next_Elmt (AI_Tag_Comp);
6657             end loop;
6658          end if;
6659       end if;
6660
6661       --  3) At the end of Access_Disp_Table, if the type has user-defined
6662       --     primitives, we add the entity of an access type declaration that
6663       --     is used by Build_Get_Prim_Op_Address to expand dispatching calls
6664       --     through the primary dispatch table.
6665
6666       if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
6667          Analyze_List (Result);
6668
6669       --     Generate:
6670       --       type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
6671       --       type Typ_DT_Acc is access Typ_DT;
6672
6673       else
6674          declare
6675             Name_DT_Prims     : constant Name_Id :=
6676                                   New_External_Name (Tname, 'G');
6677             Name_DT_Prims_Acc : constant Name_Id :=
6678                                   New_External_Name (Tname, 'H');
6679             DT_Prims          : constant Entity_Id :=
6680                                   Make_Defining_Identifier (Loc,
6681                                     Name_DT_Prims);
6682             DT_Prims_Acc      : constant Entity_Id :=
6683                                   Make_Defining_Identifier (Loc,
6684                                     Name_DT_Prims_Acc);
6685          begin
6686             Append_To (Result,
6687               Make_Full_Type_Declaration (Loc,
6688                 Defining_Identifier => DT_Prims,
6689                 Type_Definition =>
6690                   Make_Constrained_Array_Definition (Loc,
6691                     Discrete_Subtype_Definitions => New_List (
6692                       Make_Range (Loc,
6693                         Low_Bound  => Make_Integer_Literal (Loc, 1),
6694                         High_Bound => Make_Integer_Literal (Loc,
6695                                        DT_Entry_Count
6696                                          (First_Tag_Component (Typ))))),
6697                     Component_Definition =>
6698                       Make_Component_Definition (Loc,
6699                         Subtype_Indication =>
6700                           New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
6701
6702             Append_To (Result,
6703               Make_Full_Type_Declaration (Loc,
6704                 Defining_Identifier => DT_Prims_Acc,
6705                 Type_Definition =>
6706                    Make_Access_To_Object_Definition (Loc,
6707                      Subtype_Indication =>
6708                        New_Occurrence_Of (DT_Prims, Loc))));
6709
6710             Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
6711
6712             --  Analyze the resulting list and suppress the generation of the
6713             --  Init_Proc associated with the above array declaration because
6714             --  this type is never used in object declarations. It is only used
6715             --  to simplify the expansion associated with dispatching calls.
6716
6717             Analyze_List (Result);
6718             Set_Suppress_Init_Proc (Base_Type (DT_Prims));
6719
6720             --  Disable backend optimizations based on assumptions about the
6721             --  aliasing status of objects designated by the access to the
6722             --  dispatch table. Required to handle dispatch tables imported
6723             --  from C++.
6724
6725             Set_No_Strict_Aliasing (Base_Type (DT_Prims_Acc));
6726
6727             --  Add the freezing nodes of these declarations; required to avoid
6728             --  generating these freezing nodes in wrong scopes (for example in
6729             --  the IC routine of a derivation of Typ).
6730
6731             Append_List_To (Result, Freeze_Entity (DT_Prims, Loc));
6732             Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Loc));
6733
6734             --  Mark entity of dispatch table. Required by the back end to
6735             --  handle them properly.
6736
6737             Set_Is_Dispatch_Table_Entity (DT_Prims);
6738          end;
6739       end if;
6740
6741       --  Mark entities of dispatch table. Required by the back end to handle
6742       --  them properly.
6743
6744       if Present (DT) then
6745          Set_Is_Dispatch_Table_Entity (DT);
6746          Set_Is_Dispatch_Table_Entity (Etype (DT));
6747       end if;
6748
6749       if Present (Iface_DT) then
6750          Set_Is_Dispatch_Table_Entity (Iface_DT);
6751          Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
6752       end if;
6753
6754       if Is_CPP_Class (Root_Type (Typ)) then
6755          Set_Ekind (DT_Ptr, E_Variable);
6756       else
6757          Set_Ekind (DT_Ptr, E_Constant);
6758       end if;
6759
6760       Set_Is_Tag       (DT_Ptr);
6761       Set_Related_Type (DT_Ptr, Typ);
6762
6763       return Result;
6764    end Make_Tags;
6765
6766    ---------------
6767    -- New_Value --
6768    ---------------
6769
6770    function New_Value (From : Node_Id) return Node_Id is
6771       Res : constant Node_Id := Duplicate_Subexpr (From);
6772    begin
6773       if Is_Access_Type (Etype (From)) then
6774          return
6775            Make_Explicit_Dereference (Sloc (From),
6776              Prefix => Res);
6777       else
6778          return Res;
6779       end if;
6780    end New_Value;
6781
6782    -----------------------------------
6783    -- Original_View_In_Visible_Part --
6784    -----------------------------------
6785
6786    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
6787       Scop : constant Entity_Id := Scope (Typ);
6788
6789    begin
6790       --  The scope must be a package
6791
6792       if not Is_Package_Or_Generic_Package (Scop) then
6793          return False;
6794       end if;
6795
6796       --  A type with a private declaration has a private view declared in
6797       --  the visible part.
6798
6799       if Has_Private_Declaration (Typ) then
6800          return True;
6801       end if;
6802
6803       return List_Containing (Parent (Typ)) =
6804         Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
6805    end Original_View_In_Visible_Part;
6806
6807    ------------------
6808    -- Prim_Op_Kind --
6809    ------------------
6810
6811    function Prim_Op_Kind
6812      (Prim : Entity_Id;
6813       Typ  : Entity_Id) return Node_Id
6814    is
6815       Full_Typ : Entity_Id := Typ;
6816       Loc      : constant Source_Ptr := Sloc (Prim);
6817       Prim_Op  : Entity_Id;
6818
6819    begin
6820       --  Retrieve the original primitive operation
6821
6822       Prim_Op := Ultimate_Alias (Prim);
6823
6824       if Ekind (Typ) = E_Record_Type
6825         and then Present (Corresponding_Concurrent_Type (Typ))
6826       then
6827          Full_Typ := Corresponding_Concurrent_Type (Typ);
6828       end if;
6829
6830       --  When a private tagged type is completed by a concurrent type,
6831       --  retrieve the full view.
6832
6833       if Is_Private_Type (Full_Typ) then
6834          Full_Typ := Full_View (Full_Typ);
6835       end if;
6836
6837       if Ekind (Prim_Op) = E_Function then
6838
6839          --  Protected function
6840
6841          if Ekind (Full_Typ) = E_Protected_Type then
6842             return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
6843
6844          --  Task function
6845
6846          elsif Ekind (Full_Typ) = E_Task_Type then
6847             return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
6848
6849          --  Regular function
6850
6851          else
6852             return New_Reference_To (RTE (RE_POK_Function), Loc);
6853          end if;
6854
6855       else
6856          pragma Assert (Ekind (Prim_Op) = E_Procedure);
6857
6858          if Ekind (Full_Typ) = E_Protected_Type then
6859
6860             --  Protected entry
6861
6862             if Is_Primitive_Wrapper (Prim_Op)
6863               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
6864             then
6865                return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
6866
6867             --  Protected procedure
6868
6869             else
6870                return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
6871             end if;
6872
6873          elsif Ekind (Full_Typ) = E_Task_Type then
6874
6875             --  Task entry
6876
6877             if Is_Primitive_Wrapper (Prim_Op)
6878               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
6879             then
6880                return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
6881
6882             --  Task "procedure". These are the internally Expander-generated
6883             --  procedures (task body for instance).
6884
6885             else
6886                return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
6887             end if;
6888
6889          --  Regular procedure
6890
6891          else
6892             return New_Reference_To (RTE (RE_POK_Procedure), Loc);
6893          end if;
6894       end if;
6895    end Prim_Op_Kind;
6896
6897    ------------------------
6898    -- Register_Primitive --
6899    ------------------------
6900
6901    function Register_Primitive
6902      (Loc     : Source_Ptr;
6903       Prim    : Entity_Id) return List_Id
6904    is
6905       DT_Ptr        : Entity_Id;
6906       Iface_Prim    : Entity_Id;
6907       Iface_Typ     : Entity_Id;
6908       Iface_DT_Ptr  : Entity_Id;
6909       Iface_DT_Elmt : Elmt_Id;
6910       L             : constant List_Id := New_List;
6911       Pos           : Uint;
6912       Tag           : Entity_Id;
6913       Tag_Typ       : Entity_Id;
6914       Thunk_Id      : Entity_Id;
6915       Thunk_Code    : Node_Id;
6916
6917    begin
6918       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6919
6920       --  Do not register in the dispatch table eliminated primitives
6921
6922       if not RTE_Available (RE_Tag)
6923         or else Is_Eliminated (Ultimate_Alias (Prim))
6924       then
6925          return L;
6926       end if;
6927
6928       if not Present (Interface_Alias (Prim)) then
6929          Tag_Typ := Scope (DTC_Entity (Prim));
6930          Pos := DT_Position (Prim);
6931          Tag := First_Tag_Component (Tag_Typ);
6932
6933          if Is_Predefined_Dispatching_Operation (Prim)
6934            or else Is_Predefined_Dispatching_Alias (Prim)
6935          then
6936             DT_Ptr :=
6937               Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
6938
6939             Append_To (L,
6940               Build_Set_Predefined_Prim_Op_Address (Loc,
6941                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
6942                 Position     => Pos,
6943                 Address_Node =>
6944                   Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6945                     Make_Attribute_Reference (Loc,
6946                       Prefix => New_Reference_To (Prim, Loc),
6947                       Attribute_Name => Name_Unrestricted_Access))));
6948
6949             --  Register copy of the pointer to the 'size primitive in the TSD
6950
6951             if Chars (Prim) = Name_uSize
6952               and then RTE_Record_Component_Available (RE_Size_Func)
6953             then
6954                DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
6955                Append_To (L,
6956                  Build_Set_Size_Function (Loc,
6957                    Tag_Node  => New_Reference_To (DT_Ptr, Loc),
6958                    Size_Func => Prim));
6959             end if;
6960
6961          else
6962             pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
6963
6964             --  Skip registration of primitives located in the C++ part of the
6965             --  dispatch table. Their slot is set by the IC routine.
6966
6967             if not Is_CPP_Class (Root_Type (Tag_Typ))
6968               or else Pos > CPP_Num_Prims (Tag_Typ)
6969             then
6970                DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
6971                Append_To (L,
6972                  Build_Set_Prim_Op_Address (Loc,
6973                    Typ          => Tag_Typ,
6974                    Tag_Node     => New_Reference_To (DT_Ptr, Loc),
6975                    Position     => Pos,
6976                    Address_Node =>
6977                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6978                        Make_Attribute_Reference (Loc,
6979                          Prefix => New_Reference_To (Prim, Loc),
6980                          Attribute_Name => Name_Unrestricted_Access))));
6981             end if;
6982          end if;
6983
6984       --  Ada 2005 (AI-251): Primitive associated with an interface type
6985       --  Generate the code of the thunk only if the interface type is not an
6986       --  immediate ancestor of Typ; otherwise the dispatch table associated
6987       --  with the interface is the primary dispatch table and we have nothing
6988       --  else to do here.
6989
6990       else
6991          Tag_Typ   := Find_Dispatching_Type (Alias (Prim));
6992          Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
6993
6994          pragma Assert (Is_Interface (Iface_Typ));
6995
6996          --  No action needed for interfaces that are ancestors of Typ because
6997          --  their primitives are located in the primary dispatch table.
6998
6999          if Is_Ancestor (Iface_Typ, Tag_Typ) then
7000             return L;
7001
7002          --  No action needed for primitives located in the C++ part of the
7003          --  dispatch table. Their slot is set by the IC routine.
7004
7005          elsif Is_CPP_Class (Root_Type (Tag_Typ))
7006             and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
7007             and then not Is_Predefined_Dispatching_Operation (Prim)
7008             and then not Is_Predefined_Dispatching_Alias (Prim)
7009          then
7010             return L;
7011          end if;
7012
7013          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
7014
7015          if not Is_Ancestor (Iface_Typ, Tag_Typ)
7016            and then Present (Thunk_Code)
7017          then
7018             --  Generate the code necessary to fill the appropriate entry of
7019             --  the secondary dispatch table of Prim's controlling type with
7020             --  Thunk_Id's address.
7021
7022             Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
7023             Iface_DT_Ptr  := Node (Iface_DT_Elmt);
7024             pragma Assert (Has_Thunks (Iface_DT_Ptr));
7025
7026             Iface_Prim := Interface_Alias (Prim);
7027             Pos        := DT_Position (Iface_Prim);
7028             Tag        := First_Tag_Component (Iface_Typ);
7029
7030             Prepend_To (L, Thunk_Code);
7031
7032             if Is_Predefined_Dispatching_Operation (Prim)
7033               or else Is_Predefined_Dispatching_Alias (Prim)
7034             then
7035                Append_To (L,
7036                  Build_Set_Predefined_Prim_Op_Address (Loc,
7037                    Tag_Node =>
7038                      New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7039                    Position => Pos,
7040                    Address_Node =>
7041                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7042                        Make_Attribute_Reference (Loc,
7043                          Prefix          => New_Reference_To (Thunk_Id, Loc),
7044                          Attribute_Name  => Name_Unrestricted_Access))));
7045
7046                Next_Elmt (Iface_DT_Elmt);
7047                Next_Elmt (Iface_DT_Elmt);
7048                Iface_DT_Ptr := Node (Iface_DT_Elmt);
7049                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7050
7051                Append_To (L,
7052                  Build_Set_Predefined_Prim_Op_Address (Loc,
7053                    Tag_Node =>
7054                      New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
7055                    Position => Pos,
7056                    Address_Node =>
7057                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7058                        Make_Attribute_Reference (Loc,
7059                          Prefix => New_Reference_To (Alias (Prim), Loc),
7060                          Attribute_Name  => Name_Unrestricted_Access))));
7061
7062             else
7063                pragma Assert (Pos /= Uint_0
7064                  and then Pos <= DT_Entry_Count (Tag));
7065
7066                Append_To (L,
7067                  Build_Set_Prim_Op_Address (Loc,
7068                    Typ          => Iface_Typ,
7069                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
7070                    Position     => Pos,
7071                    Address_Node =>
7072                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7073                        Make_Attribute_Reference (Loc,
7074                          Prefix => New_Reference_To (Thunk_Id, Loc),
7075                          Attribute_Name => Name_Unrestricted_Access))));
7076
7077                Next_Elmt (Iface_DT_Elmt);
7078                Next_Elmt (Iface_DT_Elmt);
7079                Iface_DT_Ptr := Node (Iface_DT_Elmt);
7080                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
7081
7082                Append_To (L,
7083                  Build_Set_Prim_Op_Address (Loc,
7084                    Typ          => Iface_Typ,
7085                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
7086                    Position     => Pos,
7087                    Address_Node =>
7088                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
7089                        Make_Attribute_Reference (Loc,
7090                          Prefix => New_Reference_To (Alias (Prim), Loc),
7091                          Attribute_Name => Name_Unrestricted_Access))));
7092
7093             end if;
7094          end if;
7095       end if;
7096
7097       return L;
7098    end Register_Primitive;
7099
7100    -------------------------
7101    -- Set_All_DT_Position --
7102    -------------------------
7103
7104    procedure Set_All_DT_Position (Typ : Entity_Id) is
7105
7106       procedure Validate_Position (Prim : Entity_Id);
7107       --  Check that the position assigned to Prim is completely safe
7108       --  (it has not been assigned to a previously defined primitive
7109       --   operation of Typ)
7110
7111       -----------------------
7112       -- Validate_Position --
7113       -----------------------
7114
7115       procedure Validate_Position (Prim : Entity_Id) is
7116          Op_Elmt : Elmt_Id;
7117          Op      : Entity_Id;
7118
7119       begin
7120          --  Aliased primitives are safe
7121
7122          if Present (Alias (Prim)) then
7123             return;
7124          end if;
7125
7126          Op_Elmt := First_Elmt (Primitive_Operations (Typ));
7127          while Present (Op_Elmt) loop
7128             Op := Node (Op_Elmt);
7129
7130             --  No need to check against itself
7131
7132             if Op = Prim then
7133                null;
7134
7135             --  Primitive operations covering abstract interfaces are
7136             --  allocated later
7137
7138             elsif Present (Interface_Alias (Op)) then
7139                null;
7140
7141             --  Predefined dispatching operations are completely safe. They
7142             --  are allocated at fixed positions in a separate table.
7143
7144             elsif Is_Predefined_Dispatching_Operation (Op)
7145                or else Is_Predefined_Dispatching_Alias (Op)
7146             then
7147                null;
7148
7149             --  Aliased subprograms are safe
7150
7151             elsif Present (Alias (Op)) then
7152                null;
7153
7154             elsif DT_Position (Op) = DT_Position (Prim)
7155                and then not Is_Predefined_Dispatching_Operation (Op)
7156                and then not Is_Predefined_Dispatching_Operation (Prim)
7157                and then not Is_Predefined_Dispatching_Alias (Op)
7158                and then not Is_Predefined_Dispatching_Alias (Prim)
7159             then
7160
7161                --  Handle aliased subprograms
7162
7163                declare
7164                   Op_1 : Entity_Id;
7165                   Op_2 : Entity_Id;
7166
7167                begin
7168                   Op_1 := Op;
7169                   loop
7170                      if Present (Overridden_Operation (Op_1)) then
7171                         Op_1 := Overridden_Operation (Op_1);
7172                      elsif Present (Alias (Op_1)) then
7173                         Op_1 := Alias (Op_1);
7174                      else
7175                         exit;
7176                      end if;
7177                   end loop;
7178
7179                   Op_2 := Prim;
7180                   loop
7181                      if Present (Overridden_Operation (Op_2)) then
7182                         Op_2 := Overridden_Operation (Op_2);
7183                      elsif Present (Alias (Op_2)) then
7184                         Op_2 := Alias (Op_2);
7185                      else
7186                         exit;
7187                      end if;
7188                   end loop;
7189
7190                   if Op_1 /= Op_2 then
7191                      raise Program_Error;
7192                   end if;
7193                end;
7194             end if;
7195
7196             Next_Elmt (Op_Elmt);
7197          end loop;
7198       end Validate_Position;
7199
7200       --  Local variables
7201
7202       Parent_Typ : constant Entity_Id := Etype (Typ);
7203       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
7204       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
7205
7206       Adjusted   : Boolean := False;
7207       Finalized  : Boolean := False;
7208
7209       Count_Prim : Nat;
7210       DT_Length  : Nat;
7211       Nb_Prim    : Nat;
7212       Prim       : Entity_Id;
7213       Prim_Elmt  : Elmt_Id;
7214
7215    --  Start of processing for Set_All_DT_Position
7216
7217    begin
7218       pragma Assert (Present (First_Tag_Component (Typ)));
7219
7220       --  Set the DT_Position for each primitive operation. Perform some sanity
7221       --  checks to avoid building inconsistent dispatch tables.
7222
7223       --  First stage: Set the DTC entity of all the primitive operations. This
7224       --  is required to properly read the DT_Position attribute in the latter
7225       --  stages.
7226
7227       Prim_Elmt  := First_Prim;
7228       Count_Prim := 0;
7229       while Present (Prim_Elmt) loop
7230          Prim := Node (Prim_Elmt);
7231
7232          --  Predefined primitives have a separate dispatch table
7233
7234          if not (Is_Predefined_Dispatching_Operation (Prim)
7235                    or else
7236                  Is_Predefined_Dispatching_Alias (Prim))
7237          then
7238             Count_Prim := Count_Prim + 1;
7239          end if;
7240
7241          Set_DTC_Entity_Value (Typ, Prim);
7242
7243          --  Clear any previous value of the DT_Position attribute. In this
7244          --  way we ensure that the final position of all the primitives is
7245          --  established by the following stages of this algorithm.
7246
7247          Set_DT_Position (Prim, No_Uint);
7248
7249          Next_Elmt (Prim_Elmt);
7250       end loop;
7251
7252       declare
7253          Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
7254                         (others => False);
7255
7256          E : Entity_Id;
7257
7258          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
7259          --  Called if Typ is declared in a nested package or a public child
7260          --  package to handle inherited primitives that were inherited by Typ
7261          --  in  the visible part, but whose declaration was deferred because
7262          --  the parent operation was private and not visible at that point.
7263
7264          procedure Set_Fixed_Prim (Pos : Nat);
7265          --  Sets to true an element of the Fixed_Prim table to indicate
7266          --  that this entry of the dispatch table of Typ is occupied.
7267
7268          ------------------------------------------
7269          -- Handle_Inherited_Private_Subprograms --
7270          ------------------------------------------
7271
7272          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
7273             Op_List     : Elist_Id;
7274             Op_Elmt     : Elmt_Id;
7275             Op_Elmt_2   : Elmt_Id;
7276             Prim_Op     : Entity_Id;
7277             Parent_Subp : Entity_Id;
7278
7279          begin
7280             Op_List := Primitive_Operations (Typ);
7281
7282             Op_Elmt := First_Elmt (Op_List);
7283             while Present (Op_Elmt) loop
7284                Prim_Op := Node (Op_Elmt);
7285
7286                --  Search primitives that are implicit operations with an
7287                --  internal name whose parent operation has a normal name.
7288
7289                if Present (Alias (Prim_Op))
7290                  and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
7291                  and then not Comes_From_Source (Prim_Op)
7292                  and then Is_Internal_Name (Chars (Prim_Op))
7293                  and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
7294                then
7295                   Parent_Subp := Alias (Prim_Op);
7296
7297                   --  Check if the type has an explicit overriding for this
7298                   --  primitive.
7299
7300                   Op_Elmt_2 := Next_Elmt (Op_Elmt);
7301                   while Present (Op_Elmt_2) loop
7302                      if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
7303                        and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
7304                      then
7305                         Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
7306                         Set_DT_Position (Node (Op_Elmt_2),
7307                           DT_Position (Parent_Subp));
7308                         Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
7309
7310                         goto Next_Primitive;
7311                      end if;
7312
7313                      Next_Elmt (Op_Elmt_2);
7314                   end loop;
7315                end if;
7316
7317                <<Next_Primitive>>
7318                Next_Elmt (Op_Elmt);
7319             end loop;
7320          end Handle_Inherited_Private_Subprograms;
7321
7322          --------------------
7323          -- Set_Fixed_Prim --
7324          --------------------
7325
7326          procedure Set_Fixed_Prim (Pos : Nat) is
7327          begin
7328             pragma Assert (Pos <= Count_Prim);
7329             Fixed_Prim (Pos) := True;
7330          exception
7331             when Constraint_Error =>
7332                raise Program_Error;
7333          end Set_Fixed_Prim;
7334
7335       begin
7336          --  In case of nested packages and public child package it may be
7337          --  necessary a special management on inherited subprograms so that
7338          --  the dispatch table is properly filled.
7339
7340          if Ekind (Scope (Scope (Typ))) = E_Package
7341            and then Scope (Scope (Typ)) /= Standard_Standard
7342            and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
7343                        or else
7344                         (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
7345                           and then Is_Generic_Type (Typ)))
7346            and then In_Open_Scopes (Scope (Etype (Typ)))
7347            and then Typ = Base_Type (Typ)
7348          then
7349             Handle_Inherited_Private_Subprograms (Typ);
7350          end if;
7351
7352          --  Second stage: Register fixed entries
7353
7354          Nb_Prim   := 0;
7355          Prim_Elmt := First_Prim;
7356          while Present (Prim_Elmt) loop
7357             Prim := Node (Prim_Elmt);
7358
7359             --  Predefined primitives have a separate table and all its
7360             --  entries are at predefined fixed positions.
7361
7362             if Is_Predefined_Dispatching_Operation (Prim) then
7363                Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
7364
7365             elsif Is_Predefined_Dispatching_Alias (Prim) then
7366                Set_DT_Position (Prim,
7367                  Default_Prim_Op_Position (Ultimate_Alias (Prim)));
7368
7369             --  Overriding primitives of ancestor abstract interfaces
7370
7371             elsif Present (Interface_Alias (Prim))
7372               and then Is_Ancestor
7373                          (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
7374             then
7375                pragma Assert (DT_Position (Prim) = No_Uint
7376                  and then Present (DTC_Entity (Interface_Alias (Prim))));
7377
7378                E := Interface_Alias (Prim);
7379                Set_DT_Position (Prim, DT_Position (E));
7380
7381                pragma Assert
7382                  (DT_Position (Alias (Prim)) = No_Uint
7383                     or else DT_Position (Alias (Prim)) = DT_Position (E));
7384                Set_DT_Position (Alias (Prim), DT_Position (E));
7385                Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
7386
7387             --  Overriding primitives must use the same entry as the
7388             --  overridden primitive.
7389
7390             elsif not Present (Interface_Alias (Prim))
7391               and then Present (Alias (Prim))
7392               and then Chars (Prim) = Chars (Alias (Prim))
7393               and then Find_Dispatching_Type (Alias (Prim)) /= Typ
7394               and then Is_Ancestor
7395                          (Find_Dispatching_Type (Alias (Prim)), Typ)
7396               and then Present (DTC_Entity (Alias (Prim)))
7397             then
7398                E := Alias (Prim);
7399                Set_DT_Position (Prim, DT_Position (E));
7400
7401                if not Is_Predefined_Dispatching_Alias (E) then
7402                   Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
7403                end if;
7404             end if;
7405
7406             Next_Elmt (Prim_Elmt);
7407          end loop;
7408
7409          --  Third stage: Fix the position of all the new primitives.
7410          --  Entries associated with primitives covering interfaces
7411          --  are handled in a latter round.
7412
7413          Prim_Elmt := First_Prim;
7414          while Present (Prim_Elmt) loop
7415             Prim := Node (Prim_Elmt);
7416
7417             --  Skip primitives previously set entries
7418
7419             if DT_Position (Prim) /= No_Uint then
7420                null;
7421
7422             --  Primitives covering interface primitives are handled later
7423
7424             elsif Present (Interface_Alias (Prim)) then
7425                null;
7426
7427             else
7428                --  Take the next available position in the DT
7429
7430                loop
7431                   Nb_Prim := Nb_Prim + 1;
7432                   pragma Assert (Nb_Prim <= Count_Prim);
7433                   exit when not Fixed_Prim (Nb_Prim);
7434                end loop;
7435
7436                Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
7437                Set_Fixed_Prim (Nb_Prim);
7438             end if;
7439
7440             Next_Elmt (Prim_Elmt);
7441          end loop;
7442       end;
7443
7444       --  Fourth stage: Complete the decoration of primitives covering
7445       --  interfaces (that is, propagate the DT_Position attribute
7446       --  from the aliased primitive)
7447
7448       Prim_Elmt := First_Prim;
7449       while Present (Prim_Elmt) loop
7450          Prim := Node (Prim_Elmt);
7451
7452          if DT_Position (Prim) = No_Uint
7453            and then Present (Interface_Alias (Prim))
7454          then
7455             pragma Assert (Present (Alias (Prim))
7456               and then Find_Dispatching_Type (Alias (Prim)) = Typ);
7457
7458             --  Check if this entry will be placed in the primary DT
7459
7460             if Is_Ancestor
7461                 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
7462             then
7463                pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
7464                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
7465
7466             --  Otherwise it will be placed in the secondary DT
7467
7468             else
7469                pragma Assert
7470                  (DT_Position (Interface_Alias (Prim)) /= No_Uint);
7471                Set_DT_Position (Prim,
7472                  DT_Position (Interface_Alias (Prim)));
7473             end if;
7474          end if;
7475
7476          Next_Elmt (Prim_Elmt);
7477       end loop;
7478
7479       --  Generate listing showing the contents of the dispatch tables.
7480       --  This action is done before some further static checks because
7481       --  in case of critical errors caused by a wrong dispatch table
7482       --  we need to see the contents of such table.
7483
7484       if Debug_Flag_ZZ then
7485          Write_DT (Typ);
7486       end if;
7487
7488       --  Final stage: Ensure that the table is correct plus some further
7489       --  verifications concerning the primitives.
7490
7491       Prim_Elmt := First_Prim;
7492       DT_Length := 0;
7493       while Present (Prim_Elmt) loop
7494          Prim := Node (Prim_Elmt);
7495
7496          --  At this point all the primitives MUST have a position
7497          --  in the dispatch table.
7498
7499          if DT_Position (Prim) = No_Uint then
7500             raise Program_Error;
7501          end if;
7502
7503          --  Calculate real size of the dispatch table
7504
7505          if not (Is_Predefined_Dispatching_Operation (Prim)
7506                    or else Is_Predefined_Dispatching_Alias (Prim))
7507            and then UI_To_Int (DT_Position (Prim)) > DT_Length
7508          then
7509             DT_Length := UI_To_Int (DT_Position (Prim));
7510          end if;
7511
7512          --  Ensure that the assigned position to non-predefined
7513          --  dispatching operations in the dispatch table is correct.
7514
7515          if not (Is_Predefined_Dispatching_Operation (Prim)
7516                    or else Is_Predefined_Dispatching_Alias (Prim))
7517          then
7518             Validate_Position (Prim);
7519          end if;
7520
7521          if Chars (Prim) = Name_Finalize then
7522             Finalized := True;
7523          end if;
7524
7525          if Chars (Prim) = Name_Adjust then
7526             Adjusted := True;
7527          end if;
7528
7529          --  An abstract operation cannot be declared in the private part for a
7530          --  visible abstract type, because it can't be overridden outside this
7531          --  package hierarchy. For explicit declarations this is checked at
7532          --  the point of declaration, but for inherited operations it must be
7533          --  done when building the dispatch table.
7534
7535          --  Ada 2005 (AI-251): Primitives associated with interfaces are
7536          --  excluded from this check because interfaces must be visible in
7537          --  the public and private part (RM 7.3 (7.3/2))
7538
7539          if Is_Abstract_Type (Typ)
7540            and then Is_Abstract_Subprogram (Prim)
7541            and then Present (Alias (Prim))
7542            and then not Is_Interface
7543                           (Find_Dispatching_Type (Ultimate_Alias (Prim)))
7544            and then not Present (Interface_Alias (Prim))
7545            and then Is_Derived_Type (Typ)
7546            and then In_Private_Part (Current_Scope)
7547            and then
7548              List_Containing (Parent (Prim)) =
7549                Private_Declarations
7550                 (Specification (Unit_Declaration_Node (Current_Scope)))
7551            and then Original_View_In_Visible_Part (Typ)
7552          then
7553             --  We exclude Input and Output stream operations because
7554             --  Limited_Controlled inherits useless Input and Output
7555             --  stream operations from Root_Controlled, which can
7556             --  never be overridden.
7557
7558             if not Is_TSS (Prim, TSS_Stream_Input)
7559                  and then
7560                not Is_TSS (Prim, TSS_Stream_Output)
7561             then
7562                Error_Msg_NE
7563                  ("abstract inherited private operation&" &
7564                   " must be overridden (RM 3.9.3(10))",
7565                  Parent (Typ), Prim);
7566             end if;
7567          end if;
7568
7569          Next_Elmt (Prim_Elmt);
7570       end loop;
7571
7572       --  Additional check
7573
7574       if Is_Controlled (Typ) then
7575          if not Finalized then
7576             Error_Msg_N
7577               ("controlled type has no explicit Finalize method?", Typ);
7578
7579          elsif not Adjusted then
7580             Error_Msg_N
7581               ("controlled type has no explicit Adjust method?", Typ);
7582          end if;
7583       end if;
7584
7585       --  Set the final size of the Dispatch Table
7586
7587       Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
7588
7589       --  The derived type must have at least as many components as its parent
7590       --  (for root types Etype points to itself and the test cannot fail).
7591
7592       if DT_Entry_Count (The_Tag) <
7593            DT_Entry_Count (First_Tag_Component (Parent_Typ))
7594       then
7595          raise Program_Error;
7596       end if;
7597    end Set_All_DT_Position;
7598
7599    --------------------------
7600    -- Set_CPP_Constructors --
7601    --------------------------
7602
7603    procedure Set_CPP_Constructors (Typ : Entity_Id) is
7604
7605       procedure Set_CPP_Constructors_Old (Typ : Entity_Id);
7606       --  For backward compatibility this routine handles CPP constructors
7607       --  of non-tagged types.
7608
7609       procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is
7610          Loc   : Source_Ptr;
7611          Init  : Entity_Id;
7612          E     : Entity_Id;
7613          Found : Boolean := False;
7614          P     : Node_Id;
7615          Parms : List_Id;
7616
7617       begin
7618          --  Look for the constructor entities
7619
7620          E := Next_Entity (Typ);
7621          while Present (E) loop
7622             if Ekind (E) = E_Function
7623               and then Is_Constructor (E)
7624             then
7625                --  Create the init procedure
7626
7627                Found := True;
7628                Loc   := Sloc (E);
7629                Init  := Make_Defining_Identifier (Loc,
7630                           Make_Init_Proc_Name (Typ));
7631                Parms :=
7632                  New_List (
7633                    Make_Parameter_Specification (Loc,
7634                      Defining_Identifier =>
7635                        Make_Defining_Identifier (Loc, Name_X),
7636                      Parameter_Type =>
7637                        New_Reference_To (Typ, Loc)));
7638
7639                if Present (Parameter_Specifications (Parent (E))) then
7640                   P := First (Parameter_Specifications (Parent (E)));
7641                   while Present (P) loop
7642                      Append_To (Parms,
7643                        Make_Parameter_Specification (Loc,
7644                          Defining_Identifier =>
7645                            Make_Defining_Identifier (Loc,
7646                              Chars (Defining_Identifier (P))),
7647                          Parameter_Type =>
7648                            New_Copy_Tree (Parameter_Type (P))));
7649                      Next (P);
7650                   end loop;
7651                end if;
7652
7653                Discard_Node (
7654                  Make_Subprogram_Declaration (Loc,
7655                    Make_Procedure_Specification (Loc,
7656                      Defining_Unit_Name => Init,
7657                      Parameter_Specifications => Parms)));
7658
7659                Set_Init_Proc (Typ, Init);
7660                Set_Is_Imported    (Init);
7661                Set_Interface_Name (Init, Interface_Name (E));
7662                Set_Convention     (Init, Convention_C);
7663                Set_Is_Public      (Init);
7664                Set_Has_Completion (Init);
7665             end if;
7666
7667             Next_Entity (E);
7668          end loop;
7669
7670          --  If there are no constructors, mark the type as abstract since we
7671          --  won't be able to declare objects of that type.
7672
7673          if not Found then
7674             Set_Is_Abstract_Type (Typ);
7675          end if;
7676       end Set_CPP_Constructors_Old;
7677
7678       --  Local variables
7679
7680       Loc   : Source_Ptr;
7681       E     : Entity_Id;
7682       Found : Boolean := False;
7683       P     : Node_Id;
7684       Parms : List_Id;
7685
7686       Constructor_Decl_Node : Node_Id;
7687       Constructor_Id        : Entity_Id;
7688       Wrapper_Id            : Entity_Id;
7689       Wrapper_Body_Node     : Node_Id;
7690       Actuals               : List_Id;
7691       Body_Stmts            : List_Id;
7692       Init_Tags_List        : List_Id;
7693
7694    begin
7695       pragma Assert (Is_CPP_Class (Typ));
7696
7697       --  For backward compatibility the compiler accepts C++ classes
7698       --  imported through non-tagged record types. In such case the
7699       --  wrapper of the C++ constructor is useless because the _tag
7700       --  component is not available.
7701
7702       --  Example:
7703       --     type Root is limited record ...
7704       --     pragma Import (CPP, Root);
7705       --     function New_Root return Root;
7706       --     pragma CPP_Constructor (New_Root, ... );
7707
7708       if not Is_Tagged_Type (Typ) then
7709          Set_CPP_Constructors_Old (Typ);
7710          return;
7711       end if;
7712
7713       --  Look for the constructor entities
7714
7715       E := Next_Entity (Typ);
7716       while Present (E) loop
7717          if Ekind (E) = E_Function
7718            and then Is_Constructor (E)
7719          then
7720             Found := True;
7721             Loc   := Sloc (E);
7722
7723             --  Generate the declaration of the imported C++ constructor
7724
7725             Parms :=
7726               New_List (
7727                 Make_Parameter_Specification (Loc,
7728                   Defining_Identifier =>
7729                     Make_Defining_Identifier (Loc, Name_uInit),
7730                   Parameter_Type =>
7731                     New_Reference_To (Typ, Loc)));
7732
7733             if Present (Parameter_Specifications (Parent (E))) then
7734                P := First (Parameter_Specifications (Parent (E)));
7735                while Present (P) loop
7736                   Append_To (Parms,
7737                     Make_Parameter_Specification (Loc,
7738                       Defining_Identifier =>
7739                         Make_Defining_Identifier (Loc,
7740                           Chars (Defining_Identifier (P))),
7741                       Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
7742                   Next (P);
7743                end loop;
7744             end if;
7745
7746             Constructor_Id := Make_Temporary (Loc, 'P');
7747
7748             Constructor_Decl_Node :=
7749               Make_Subprogram_Declaration (Loc,
7750                 Make_Procedure_Specification (Loc,
7751                   Defining_Unit_Name => Constructor_Id,
7752                   Parameter_Specifications => Parms));
7753
7754             Set_Is_Imported    (Constructor_Id);
7755             Set_Interface_Name (Constructor_Id, Interface_Name (E));
7756             Set_Convention     (Constructor_Id, Convention_C);
7757             Set_Is_Public      (Constructor_Id);
7758             Set_Has_Completion (Constructor_Id);
7759
7760             --  Build the wrapper of this constructor
7761
7762             Parms :=
7763               New_List (
7764                 Make_Parameter_Specification (Loc,
7765                   Defining_Identifier =>
7766                     Make_Defining_Identifier (Loc, Name_uInit),
7767                   Parameter_Type =>
7768                     New_Reference_To (Typ, Loc)));
7769
7770             if Present (Parameter_Specifications (Parent (E))) then
7771                P := First (Parameter_Specifications (Parent (E)));
7772                while Present (P) loop
7773                   Append_To (Parms,
7774                     Make_Parameter_Specification (Loc,
7775                       Defining_Identifier =>
7776                         Make_Defining_Identifier (Loc,
7777                           Chars (Defining_Identifier (P))),
7778                       Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
7779                   Next (P);
7780                end loop;
7781             end if;
7782
7783             Body_Stmts := New_List;
7784
7785             --  Invoke the C++ constructor
7786
7787             Actuals := New_List;
7788
7789             P := First (Parms);
7790             while Present (P) loop
7791                Append_To (Actuals,
7792                  New_Reference_To (Defining_Identifier (P), Loc));
7793                Next (P);
7794             end loop;
7795
7796             Append_To (Body_Stmts,
7797               Make_Procedure_Call_Statement (Loc,
7798                 Name => New_Reference_To (Constructor_Id, Loc),
7799                 Parameter_Associations => Actuals));
7800
7801             --  Initialize copies of C++ primary and secondary tags
7802
7803             Init_Tags_List := New_List;
7804
7805             declare
7806                Tag_Elmt : Elmt_Id;
7807                Tag_Comp : Node_Id;
7808
7809             begin
7810                Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
7811                Tag_Comp := First_Tag_Component (Typ);
7812
7813                while Present (Tag_Elmt)
7814                  and then Is_Tag (Node (Tag_Elmt))
7815                loop
7816                   --  Skip the following assertion with primary tags because
7817                   --  Related_Type is not set on primary tag components
7818
7819                   pragma Assert (Tag_Comp = First_Tag_Component (Typ)
7820                     or else Related_Type (Node (Tag_Elmt))
7821                               = Related_Type (Tag_Comp));
7822
7823                   Append_To (Init_Tags_List,
7824                     Make_Assignment_Statement (Loc,
7825                       Name =>
7826                         New_Reference_To (Node (Tag_Elmt), Loc),
7827                       Expression =>
7828                         Make_Selected_Component (Loc,
7829                           Prefix => Make_Identifier (Loc, Name_uInit),
7830                           Selector_Name =>
7831                             New_Reference_To (Tag_Comp, Loc))));
7832
7833                      Tag_Comp := Next_Tag_Component (Tag_Comp);
7834                   Next_Elmt (Tag_Elmt);
7835                end loop;
7836             end;
7837
7838             Append_To (Body_Stmts,
7839               Make_If_Statement (Loc,
7840                 Condition =>
7841                   Make_Op_Eq (Loc,
7842                     Left_Opnd =>
7843                       New_Reference_To
7844                         (Node (First_Elmt (Access_Disp_Table (Typ))),
7845                          Loc),
7846                     Right_Opnd =>
7847                       Unchecked_Convert_To (RTE (RE_Tag),
7848                         New_Reference_To (RTE (RE_Null_Address), Loc))),
7849                 Then_Statements => Init_Tags_List));
7850
7851             Wrapper_Id := Make_Defining_Identifier (Loc,
7852                             Make_Init_Proc_Name (Typ));
7853
7854             Wrapper_Body_Node :=
7855               Make_Subprogram_Body (Loc,
7856                 Specification =>
7857                   Make_Procedure_Specification (Loc,
7858                     Defining_Unit_Name => Wrapper_Id,
7859                     Parameter_Specifications => Parms),
7860                 Declarations => New_List (Constructor_Decl_Node),
7861                 Handled_Statement_Sequence =>
7862                   Make_Handled_Sequence_Of_Statements (Loc,
7863                     Statements => Body_Stmts,
7864                     Exception_Handlers => No_List));
7865
7866             Discard_Node (Wrapper_Body_Node);
7867             Set_Init_Proc (Typ, Wrapper_Id);
7868          end if;
7869
7870          Next_Entity (E);
7871       end loop;
7872
7873       --  If there are no constructors, mark the type as abstract since we
7874       --  won't be able to declare objects of that type.
7875
7876       if not Found then
7877          Set_Is_Abstract_Type (Typ);
7878       end if;
7879
7880       --  If the CPP type has constructors then it must import also the default
7881       --  C++ constructor. It is required for default initialization of objects
7882       --  of the type. It is also required to elaborate objects of Ada types
7883       --  that are defined as derivations of this CPP type.
7884
7885       if Has_CPP_Constructors (Typ)
7886         and then No (Init_Proc (Typ))
7887       then
7888          Error_Msg_N ("?default constructor must be imported from C++", Typ);
7889       end if;
7890    end Set_CPP_Constructors;
7891
7892    --------------------------
7893    -- Set_DTC_Entity_Value --
7894    --------------------------
7895
7896    procedure Set_DTC_Entity_Value
7897      (Tagged_Type : Entity_Id;
7898       Prim        : Entity_Id)
7899    is
7900    begin
7901       if Present (Interface_Alias (Prim))
7902         and then Is_Interface
7903                    (Find_Dispatching_Type (Interface_Alias (Prim)))
7904       then
7905          Set_DTC_Entity (Prim,
7906            Find_Interface_Tag
7907              (T     => Tagged_Type,
7908               Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
7909       else
7910          Set_DTC_Entity (Prim,
7911            First_Tag_Component (Tagged_Type));
7912       end if;
7913    end Set_DTC_Entity_Value;
7914
7915    -----------------
7916    -- Tagged_Kind --
7917    -----------------
7918
7919    function Tagged_Kind (T : Entity_Id) return Node_Id is
7920       Conc_Typ : Entity_Id;
7921       Loc      : constant Source_Ptr := Sloc (T);
7922
7923    begin
7924       pragma Assert
7925         (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
7926
7927       --  Abstract kinds
7928
7929       if Is_Abstract_Type (T) then
7930          if Is_Limited_Record (T) then
7931             return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
7932          else
7933             return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
7934          end if;
7935
7936       --  Concurrent kinds
7937
7938       elsif Is_Concurrent_Record_Type (T) then
7939          Conc_Typ := Corresponding_Concurrent_Type (T);
7940
7941          if Present (Full_View (Conc_Typ)) then
7942             Conc_Typ := Full_View (Conc_Typ);
7943          end if;
7944
7945          if Ekind (Conc_Typ) = E_Protected_Type then
7946             return New_Reference_To (RTE (RE_TK_Protected), Loc);
7947          else
7948             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
7949             return New_Reference_To (RTE (RE_TK_Task), Loc);
7950          end if;
7951
7952       --  Regular tagged kinds
7953
7954       else
7955          if Is_Limited_Record (T) then
7956             return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
7957          else
7958             return New_Reference_To (RTE (RE_TK_Tagged), Loc);
7959          end if;
7960       end if;
7961    end Tagged_Kind;
7962
7963    --------------
7964    -- Write_DT --
7965    --------------
7966
7967    procedure Write_DT (Typ : Entity_Id) is
7968       Elmt : Elmt_Id;
7969       Prim : Node_Id;
7970
7971    begin
7972       --  Protect this procedure against wrong usage. Required because it will
7973       --  be used directly from GDB
7974
7975       if not (Typ <= Last_Node_Id)
7976         or else not Is_Tagged_Type (Typ)
7977       then
7978          Write_Str ("wrong usage: Write_DT must be used with tagged types");
7979          Write_Eol;
7980          return;
7981       end if;
7982
7983       Write_Int (Int (Typ));
7984       Write_Str (": ");
7985       Write_Name (Chars (Typ));
7986
7987       if Is_Interface (Typ) then
7988          Write_Str (" is interface");
7989       end if;
7990
7991       Write_Eol;
7992
7993       Elmt := First_Elmt (Primitive_Operations (Typ));
7994       while Present (Elmt) loop
7995          Prim := Node (Elmt);
7996          Write_Str  (" - ");
7997
7998          --  Indicate if this primitive will be allocated in the primary
7999          --  dispatch table or in a secondary dispatch table associated
8000          --  with an abstract interface type
8001
8002          if Present (DTC_Entity (Prim)) then
8003             if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
8004                Write_Str ("[P] ");
8005             else
8006                Write_Str ("[s] ");
8007             end if;
8008          end if;
8009
8010          --  Output the node of this primitive operation and its name
8011
8012          Write_Int  (Int (Prim));
8013          Write_Str  (": ");
8014
8015          if Is_Predefined_Dispatching_Operation (Prim) then
8016             Write_Str ("(predefined) ");
8017          end if;
8018
8019          --  Prefix the name of the primitive with its corresponding tagged
8020          --  type to facilitate seeing inherited primitives.
8021
8022          if Present (Alias (Prim)) then
8023             Write_Name
8024               (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
8025          else
8026             Write_Name (Chars (Typ));
8027          end if;
8028
8029          Write_Str (".");
8030          Write_Name (Chars (Prim));
8031
8032          --  Indicate if this primitive has an aliased primitive
8033
8034          if Present (Alias (Prim)) then
8035             Write_Str (" (alias = ");
8036             Write_Int (Int (Alias (Prim)));
8037
8038             --  If the DTC_Entity attribute is already set we can also output
8039             --  the name of the interface covered by this primitive (if any).
8040
8041             if Present (DTC_Entity (Alias (Prim)))
8042               and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
8043             then
8044                Write_Str  (" from interface ");
8045                Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
8046             end if;
8047
8048             if Present (Interface_Alias (Prim)) then
8049                Write_Str  (", AI_Alias of ");
8050
8051                if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
8052                   Write_Str ("null primitive ");
8053                end if;
8054
8055                Write_Name
8056                  (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
8057                Write_Char (':');
8058                Write_Int  (Int (Interface_Alias (Prim)));
8059             end if;
8060
8061             Write_Str (")");
8062          end if;
8063
8064          --  Display the final position of this primitive in its associated
8065          --  (primary or secondary) dispatch table
8066
8067          if Present (DTC_Entity (Prim))
8068            and then DT_Position (Prim) /= No_Uint
8069          then
8070             Write_Str (" at #");
8071             Write_Int (UI_To_Int (DT_Position (Prim)));
8072          end if;
8073
8074          if Is_Abstract_Subprogram (Prim) then
8075             Write_Str (" is abstract;");
8076
8077          --  Check if this is a null primitive
8078
8079          elsif Comes_From_Source (Prim)
8080            and then Ekind (Prim) = E_Procedure
8081            and then Null_Present (Parent (Prim))
8082          then
8083             Write_Str (" is null;");
8084          end if;
8085
8086          if Is_Eliminated (Ultimate_Alias (Prim)) then
8087             Write_Str (" (eliminated)");
8088          end if;
8089
8090          if Is_Imported (Prim)
8091            and then Convention (Prim) = Convention_CPP
8092          then
8093             Write_Str (" (C++)");
8094          end if;
8095
8096          Write_Eol;
8097
8098          Next_Elmt (Elmt);
8099       end loop;
8100    end Write_DT;
8101
8102 end Exp_Disp;