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