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