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