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