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