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