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