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-2007, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Exp_Atag; use Exp_Atag;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Exp_Dbug; use Exp_Dbug;
  36 with Exp_Tss;  use Exp_Tss;
  37 with Exp_Util; use Exp_Util;
  38 with Freeze;   use Freeze;
  39 with Itypes;   use Itypes;
  40 with Lib;      use Lib;
  41 with Nlists;   use Nlists;
  42 with Nmake;    use Nmake;
  43 with Namet;    use Namet;
  44 with Opt;      use Opt;
  45 with Output;   use Output;
  46 with Restrict; use Restrict;
  47 with Rident;   use Rident;
  48 with Rtsfind;  use Rtsfind;
  49 with Sem;      use Sem;
  50 with Sem_Ch6;  use Sem_Ch6;
  51 with Sem_Ch8;  use Sem_Ch8;
  52 with Sem_Disp; use Sem_Disp;
  53 with Sem_Eval; use Sem_Eval;
  54 with Sem_Res;  use Sem_Res;
  55 with Sem_Type; use Sem_Type;
  56 with Sem_Util; use Sem_Util;
  57 with Sinfo;    use Sinfo;
  58 with Snames;   use Snames;
  59 with Stand;    use Stand;
  60 with Stringt;  use Stringt;
  61 with Targparm; use Targparm;
  62 with Tbuild;   use Tbuild;
  63 with Uintp;    use Uintp;
  64
  65 package body Exp_Disp is
  66
  67    -----------------------
  68    -- Local Subprograms --
  69    -----------------------
  70
  71    function Default_Prim_Op_Position (E : Entity_Id) return Uint;
  72    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
  73    --  of the default primitive operations.
  74
  75    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean;
  76    --  Returns true if Prim is not a predefined dispatching primitive but it is
  77    --  an alias of a predefined dispatching primitive (ie. through a renaming)
  78
  79    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
  80    --  Check if the type has a private view or if the public view appears
  81    --  in the visible part of a package spec.
  82
  83    function Prim_Op_Kind
  84      (Prim : Entity_Id;
  85       Typ  : Entity_Id) return Node_Id;
  86    --  Ada 2005 (AI-345): Determine the primitive operation kind of Prim
  87    --  according to its type Typ. Return a reference to an RE_Prim_Op_Kind
  88    --  enumeration value.
  89
  90    function Tagged_Kind (T : Entity_Id) return Node_Id;
  91    --  Ada 2005 (AI-345): Determine the tagged kind of T and return a reference
  92    --  to an RE_Tagged_Kind enumeration value.
  93
  94    ------------------------------
  95    -- Default_Prim_Op_Position --
  96    ------------------------------
  97
  98    function Default_Prim_Op_Position (E : Entity_Id) return Uint is
  99       TSS_Name : TSS_Name_Type;
 100
 101    begin
 102       Get_Name_String (Chars (E));
 103       TSS_Name :=
 104         TSS_Name_Type
 105           (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
 106
 107       if Chars (E) = Name_uSize then
 108          return Uint_1;
 109
 110       elsif Chars (E) = Name_uAlignment then
 111          return Uint_2;
 112
 113       elsif TSS_Name = TSS_Stream_Read then
 114          return Uint_3;
 115
 116       elsif TSS_Name = TSS_Stream_Write then
 117          return Uint_4;
 118
 119       elsif TSS_Name = TSS_Stream_Input then
 120          return Uint_5;
 121
 122       elsif TSS_Name = TSS_Stream_Output then
 123          return Uint_6;
 124
 125       elsif Chars (E) = Name_Op_Eq then
 126          return Uint_7;
 127
 128       elsif Chars (E) = Name_uAssign then
 129          return Uint_8;
 130
 131       elsif TSS_Name = TSS_Deep_Adjust then
 132          return Uint_9;
 133
 134       elsif TSS_Name = TSS_Deep_Finalize then
 135          return Uint_10;
 136
 137       elsif Ada_Version >= Ada_05 then
 138          if Chars (E) = Name_uDisp_Asynchronous_Select then
 139             return Uint_11;
 140
 141          elsif Chars (E) = Name_uDisp_Conditional_Select then
 142             return Uint_12;
 143
 144          elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
 145             return Uint_13;
 146
 147          elsif Chars (E) = Name_uDisp_Get_Task_Id then
 148             return Uint_14;
 149
 150          elsif Chars (E) = Name_uDisp_Timed_Select then
 151             return Uint_15;
 152          end if;
 153       end if;
 154
 155       raise Program_Error;
 156    end Default_Prim_Op_Position;
 157
 158    -----------------------------
 159    -- Expand_Dispatching_Call --
 160    -----------------------------
 161
 162    procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
 163       Loc      : constant Source_Ptr := Sloc (Call_Node);
 164       Call_Typ : constant Entity_Id  := Etype (Call_Node);
 165
 166       Ctrl_Arg   : constant Node_Id := Controlling_Argument (Call_Node);
 167       Param_List : constant List_Id := Parameter_Associations (Call_Node);
 168
 169       Subp            : Entity_Id;
 170       CW_Typ          : Entity_Id;
 171       New_Call        : Node_Id;
 172       New_Call_Name   : Node_Id;
 173       New_Params      : List_Id := No_List;
 174       Param           : Node_Id;
 175       Res_Typ         : Entity_Id;
 176       Subp_Ptr_Typ    : Entity_Id;
 177       Subp_Typ        : Entity_Id;
 178       Typ             : Entity_Id;
 179       Eq_Prim_Op      : Entity_Id := Empty;
 180       Controlling_Tag : Node_Id;
 181
 182       function New_Value (From : Node_Id) return Node_Id;
 183       --  From is the original Expression. New_Value is equivalent to a call
 184       --  to Duplicate_Subexpr with an explicit dereference when From is an
 185       --  access parameter.
 186
 187       ---------------
 188       -- New_Value --
 189       ---------------
 190
 191       function New_Value (From : Node_Id) return Node_Id is
 192          Res : constant Node_Id := Duplicate_Subexpr (From);
 193       begin
 194          if Is_Access_Type (Etype (From)) then
 195             return
 196               Make_Explicit_Dereference (Sloc (From),
 197                 Prefix => Res);
 198          else
 199             return Res;
 200          end if;
 201       end New_Value;
 202
 203    --  Start of processing for Expand_Dispatching_Call
 204
 205    begin
 206       if No_Run_Time_Mode then
 207          Error_Msg_CRT ("tagged types", Call_Node);
 208          return;
 209       end if;
 210
 211       --  Expand_Dispatching_Call is called directly from the semantics,
 212       --  so we need a check to see whether expansion is active before
 213       --  proceeding. In addition, there is no need to expand the call
 214       --  if we are compiling under restriction No_Dispatching_Calls;
 215       --  the semantic analyzer has previously notified the violation
 216       --  of this restriction.
 217
 218       if not Expander_Active
 219         or else Restriction_Active (No_Dispatching_Calls)
 220       then
 221          return;
 222       end if;
 223
 224       --  Set subprogram. If this is an inherited operation that was
 225       --  overridden, the body that is being called is its alias.
 226
 227       Subp := Entity (Name (Call_Node));
 228
 229       if Present (Alias (Subp))
 230         and then Is_Inherited_Operation (Subp)
 231         and then No (DTC_Entity (Subp))
 232       then
 233          Subp := Alias (Subp);
 234       end if;
 235
 236       --  Definition of the class-wide type and the tagged type
 237
 238       --  If the controlling argument is itself a tag rather than a tagged
 239       --  object, then use the class-wide type associated with the subprogram's
 240       --  controlling type. This case can occur when a call to an inherited
 241       --  primitive has an actual that originated from a default parameter
 242       --  given by a tag-indeterminate call and when there is no other
 243       --  controlling argument providing the tag (AI-239 requires dispatching).
 244       --  This capability of dispatching directly by tag is also needed by the
 245       --  implementation of AI-260 (for the generic dispatching constructors).
 246
 247       if Etype (Ctrl_Arg) = RTE (RE_Tag)
 248         or else (RTE_Available (RE_Interface_Tag)
 249                   and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
 250       then
 251          CW_Typ := Class_Wide_Type (Find_Dispatching_Type (Subp));
 252
 253       --  Class_Wide_Type is applied to the expressions used to initialize
 254       --  CW_Typ, to ensure that CW_Typ always denotes a class-wide type, since
 255       --  there are cases where the controlling type is resolved to a specific
 256       --  type (such as for designated types of arguments such as CW'Access).
 257
 258       elsif Is_Access_Type (Etype (Ctrl_Arg)) then
 259          CW_Typ := Class_Wide_Type (Designated_Type (Etype (Ctrl_Arg)));
 260
 261       else
 262          CW_Typ := Class_Wide_Type (Etype (Ctrl_Arg));
 263       end if;
 264
 265       Typ := Root_Type (CW_Typ);
 266
 267       if Ekind (Typ) = E_Incomplete_Type then
 268          Typ := Non_Limited_View (Typ);
 269       end if;
 270
 271       if not Is_Limited_Type (Typ) then
 272          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
 273       end if;
 274
 275       --  Dispatching call to C++ primitive. Create a new parameter list
 276       --  with no tag checks.
 277
 278       if Is_CPP_Class (Typ) then
 279          New_Params := New_List;
 280          Param := First_Actual (Call_Node);
 281          while Present (Param) loop
 282             Append_To (New_Params, Relocate_Node (Param));
 283             Next_Actual (Param);
 284          end loop;
 285
 286       --  Dispatching call to Ada primitive
 287
 288       elsif Present (Param_List) then
 289
 290          --  Generate the Tag checks when appropriate
 291
 292          New_Params := New_List;
 293          Param := First_Actual (Call_Node);
 294          while Present (Param) loop
 295
 296             --  No tag check with itself
 297
 298             if Param = Ctrl_Arg then
 299                Append_To (New_Params,
 300                  Duplicate_Subexpr_Move_Checks (Param));
 301
 302             --  No tag check for parameter whose type is neither tagged nor
 303             --  access to tagged (for access parameters)
 304
 305             elsif No (Find_Controlling_Arg (Param)) then
 306                Append_To (New_Params, Relocate_Node (Param));
 307
 308             --  No tag check for function dispatching on result if the
 309             --  Tag given by the context is this one
 310
 311             elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
 312                Append_To (New_Params, Relocate_Node (Param));
 313
 314             --  "=" is the only dispatching operation allowed to get
 315             --  operands with incompatible tags (it just returns false).
 316             --  We use Duplicate_Subexpr_Move_Checks instead of calling
 317             --  Relocate_Node because the value will be duplicated to
 318             --  check the tags.
 319
 320             elsif Subp = Eq_Prim_Op then
 321                Append_To (New_Params,
 322                  Duplicate_Subexpr_Move_Checks (Param));
 323
 324             --  No check in presence of suppress flags
 325
 326             elsif Tag_Checks_Suppressed (Etype (Param))
 327               or else (Is_Access_Type (Etype (Param))
 328                          and then Tag_Checks_Suppressed
 329                                     (Designated_Type (Etype (Param))))
 330             then
 331                Append_To (New_Params, Relocate_Node (Param));
 332
 333             --  Optimization: no tag checks if the parameters are identical
 334
 335             elsif Is_Entity_Name (Param)
 336               and then Is_Entity_Name (Ctrl_Arg)
 337               and then Entity (Param) = Entity (Ctrl_Arg)
 338             then
 339                Append_To (New_Params, Relocate_Node (Param));
 340
 341             --  Now we need to generate the Tag check
 342
 343             else
 344                --  Generate code for tag equality check
 345                --  Perhaps should have Checks.Apply_Tag_Equality_Check???
 346
 347                Insert_Action (Ctrl_Arg,
 348                  Make_Implicit_If_Statement (Call_Node,
 349                    Condition =>
 350                      Make_Op_Ne (Loc,
 351                        Left_Opnd =>
 352                          Make_Selected_Component (Loc,
 353                            Prefix => New_Value (Ctrl_Arg),
 354                            Selector_Name =>
 355                              New_Reference_To
 356                                (First_Tag_Component (Typ), Loc)),
 357
 358                        Right_Opnd =>
 359                          Make_Selected_Component (Loc,
 360                            Prefix =>
 361                              Unchecked_Convert_To (Typ, New_Value (Param)),
 362                            Selector_Name =>
 363                              New_Reference_To
 364                                (First_Tag_Component (Typ), Loc))),
 365
 366                    Then_Statements =>
 367                      New_List (New_Constraint_Error (Loc))));
 368
 369                Append_To (New_Params, Relocate_Node (Param));
 370             end if;
 371
 372             Next_Actual (Param);
 373          end loop;
 374       end if;
 375
 376       --  Generate the appropriate subprogram pointer type
 377
 378       if Etype (Subp) = Typ then
 379          Res_Typ := CW_Typ;
 380       else
 381          Res_Typ := Etype (Subp);
 382       end if;
 383
 384       Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
 385       Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
 386       Set_Etype          (Subp_Typ, Res_Typ);
 387       Init_Size_Align    (Subp_Ptr_Typ);
 388       Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
 389
 390       --  Create a new list of parameters which is a copy of the old formal
 391       --  list including the creation of a new set of matching entities.
 392
 393       declare
 394          Old_Formal : Entity_Id := First_Formal (Subp);
 395          New_Formal : Entity_Id;
 396          Extra      : Entity_Id := Empty;
 397
 398       begin
 399          if Present (Old_Formal) then
 400             New_Formal := New_Copy (Old_Formal);
 401             Set_First_Entity (Subp_Typ, New_Formal);
 402             Param := First_Actual (Call_Node);
 403
 404             loop
 405                Set_Scope (New_Formal, Subp_Typ);
 406
 407                --  Change all the controlling argument types to be class-wide
 408                --  to avoid a recursion in dispatching.
 409
 410                if Is_Controlling_Formal (New_Formal) then
 411                   Set_Etype (New_Formal, Etype (Param));
 412                end if;
 413
 414                if Is_Itype (Etype (New_Formal)) then
 415                   Extra := New_Copy (Etype (New_Formal));
 416
 417                   if Ekind (Extra) = E_Record_Subtype
 418                     or else Ekind (Extra) = E_Class_Wide_Subtype
 419                   then
 420                      Set_Cloned_Subtype (Extra, Etype (New_Formal));
 421                   end if;
 422
 423                   Set_Etype (New_Formal, Extra);
 424                   Set_Scope (Etype (New_Formal), Subp_Typ);
 425                end if;
 426
 427                Extra := New_Formal;
 428                Next_Formal (Old_Formal);
 429                exit when No (Old_Formal);
 430
 431                Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
 432                Next_Entity (New_Formal);
 433                Next_Actual (Param);
 434             end loop;
 435
 436             Set_Next_Entity (New_Formal, Empty);
 437             Set_Last_Entity (Subp_Typ, Extra);
 438          end if;
 439
 440          --  Now that the explicit formals have been duplicated, any extra
 441          --  formals needed by the subprogram must be created.
 442
 443          if Present (Extra) then
 444             Set_Extra_Formal (Extra, Empty);
 445          end if;
 446
 447          Create_Extra_Formals (Subp_Typ);
 448       end;
 449
 450       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
 451       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
 452
 453       --  If the controlling argument is a value of type Ada.Tag or an abstract
 454       --  interface class-wide type then use it directly. Otherwise, the tag
 455       --  must be extracted from the controlling object.
 456
 457       if Etype (Ctrl_Arg) = RTE (RE_Tag)
 458         or else (RTE_Available (RE_Interface_Tag)
 459                   and then Etype (Ctrl_Arg) = RTE (RE_Interface_Tag))
 460       then
 461          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
 462
 463       --  Extract the tag from an unchecked type conversion. Done to avoid
 464       --  the expansion of additional code just to obtain the value of such
 465       --  tag because the current management of interface type conversions
 466       --  generates in some cases this unchecked type conversion with the
 467       --  tag of the object (see Expand_Interface_Conversion).
 468
 469       elsif Nkind (Ctrl_Arg) = N_Unchecked_Type_Conversion
 470         and then
 471           (Etype (Expression (Ctrl_Arg)) = RTE (RE_Tag)
 472             or else
 473               (RTE_Available (RE_Interface_Tag)
 474                 and then
 475                   Etype (Expression (Ctrl_Arg)) = RTE (RE_Interface_Tag)))
 476       then
 477          Controlling_Tag := Duplicate_Subexpr (Expression (Ctrl_Arg));
 478
 479       --  Ada 2005 (AI-251): Abstract interface class-wide type
 480
 481       elsif Is_Interface (Etype (Ctrl_Arg))
 482          and then Is_Class_Wide_Type (Etype (Ctrl_Arg))
 483       then
 484          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
 485
 486       else
 487          Controlling_Tag :=
 488            Make_Selected_Component (Loc,
 489              Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
 490              Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
 491       end if;
 492
 493       --  Handle dispatching calls to predefined primitives
 494
 495       if Is_Predefined_Dispatching_Operation (Subp)
 496         or else Is_Predefined_Dispatching_Alias (Subp)
 497       then
 498          New_Call_Name :=
 499            Unchecked_Convert_To (Subp_Ptr_Typ,
 500              Build_Get_Predefined_Prim_Op_Address (Loc,
 501                Tag_Node => Controlling_Tag,
 502                Position => DT_Position (Subp)));
 503
 504       --  Handle dispatching calls to user-defined primitives
 505
 506       else
 507          New_Call_Name :=
 508            Unchecked_Convert_To (Subp_Ptr_Typ,
 509              Build_Get_Prim_Op_Address (Loc,
 510                Typ      => Find_Dispatching_Type (Subp),
 511                Tag_Node => Controlling_Tag,
 512                Position => DT_Position (Subp)));
 513       end if;
 514
 515       if Nkind (Call_Node) = N_Function_Call then
 516
 517          New_Call :=
 518            Make_Function_Call (Loc,
 519              Name => New_Call_Name,
 520              Parameter_Associations => New_Params);
 521
 522          --  If this is a dispatching "=", we must first compare the tags so
 523          --  we generate: x.tag = y.tag and then x = y
 524
 525          if Subp = Eq_Prim_Op then
 526             Param := First_Actual (Call_Node);
 527             New_Call :=
 528               Make_And_Then (Loc,
 529                 Left_Opnd =>
 530                      Make_Op_Eq (Loc,
 531                        Left_Opnd =>
 532                          Make_Selected_Component (Loc,
 533                            Prefix => New_Value (Param),
 534                            Selector_Name =>
 535                              New_Reference_To (First_Tag_Component (Typ),
 536                                                Loc)),
 537
 538                        Right_Opnd =>
 539                          Make_Selected_Component (Loc,
 540                            Prefix =>
 541                              Unchecked_Convert_To (Typ,
 542                                New_Value (Next_Actual (Param))),
 543                            Selector_Name =>
 544                              New_Reference_To (First_Tag_Component (Typ),
 545                                                Loc))),
 546                 Right_Opnd => New_Call);
 547          end if;
 548
 549       else
 550          New_Call :=
 551            Make_Procedure_Call_Statement (Loc,
 552              Name => New_Call_Name,
 553              Parameter_Associations => New_Params);
 554       end if;
 555
 556       Rewrite (Call_Node, New_Call);
 557
 558       --  Suppress all checks during the analysis of the expanded code
 559       --  to avoid the generation of spureous warnings under ZFP run-time.
 560
 561       Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
 562    end Expand_Dispatching_Call;
 563
 564    ---------------------------------
 565    -- Expand_Interface_Conversion --
 566    ---------------------------------
 567
 568    procedure Expand_Interface_Conversion
 569      (N         : Node_Id;
 570       Is_Static : Boolean := True)
 571    is
 572       Loc         : constant Source_Ptr := Sloc (N);
 573       Etyp        : constant Entity_Id  := Etype (N);
 574       Operand     : constant Node_Id    := Expression (N);
 575       Operand_Typ : Entity_Id           := Etype (Operand);
 576       Fent        : Entity_Id;
 577       Func        : Node_Id;
 578       Iface_Typ   : Entity_Id           := Etype (N);
 579       Iface_Tag   : Entity_Id;
 580       New_Itype   : Entity_Id;
 581       Stats       : List_Id;
 582
 583    begin
 584       --  Ada 2005 (AI-345): Handle synchronized interface type derivations
 585
 586       if Is_Concurrent_Type (Operand_Typ) then
 587          Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
 588       end if;
 589
 590       --  Handle access types to interfaces
 591
 592       if Is_Access_Type (Iface_Typ) then
 593          Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
 594       end if;
 595
 596       --  Handle class-wide interface types. This conversion can appear
 597       --  explicitly in the source code. Example: I'Class (Obj)
 598
 599       if Is_Class_Wide_Type (Iface_Typ) then
 600          Iface_Typ := Root_Type (Iface_Typ);
 601       end if;
 602
 603       pragma Assert (not Is_Static
 604         or else (not Is_Class_Wide_Type (Iface_Typ)
 605                   and then Is_Interface (Iface_Typ)));
 606
 607       if VM_Target /= No_VM then
 608
 609          --  For VM, just do a conversion ???
 610
 611          Rewrite (N, Unchecked_Convert_To (Etype (N), N));
 612          Analyze (N);
 613          return;
 614       end if;
 615
 616       if not Is_Static then
 617
 618          --  Give error if configurable run time and Displace not available
 619
 620          if not RTE_Available (RE_Displace) then
 621             Error_Msg_CRT ("abstract interface types", N);
 622             return;
 623          end if;
 624
 625          --  Handle conversion of access-to-class-wide interface types. Target
 626          --  can be an access to an object or an access to another class-wide
 627          --  interface (see -1- and -2- in the following example):
 628
 629          --     type Iface1_Ref is access all Iface1'Class;
 630          --     type Iface2_Ref is access all Iface1'Class;
 631
 632          --     Acc1 : Iface1_Ref := new ...
 633          --     Obj  : Obj_Ref    := Obj_Ref (Acc);    -- 1
 634          --     Acc2 : Iface2_Ref := Iface2_Ref (Acc); -- 2
 635
 636          if Is_Access_Type (Operand_Typ) then
 637             pragma Assert
 638               (Is_Interface (Directly_Designated_Type (Operand_Typ)));
 639
 640             Rewrite (N,
 641               Unchecked_Convert_To (Etype (N),
 642                 Make_Function_Call (Loc,
 643                   Name => New_Reference_To (RTE (RE_Displace), Loc),
 644                   Parameter_Associations => New_List (
 645
 646                     Unchecked_Convert_To (RTE (RE_Address),
 647                       Relocate_Node (Expression (N))),
 648
 649                     New_Occurrence_Of
 650                       (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
 651                        Loc)))));
 652
 653             Analyze (N);
 654             return;
 655          end if;
 656
 657          Rewrite (N,
 658            Make_Function_Call (Loc,
 659              Name => New_Reference_To (RTE (RE_Displace), Loc),
 660              Parameter_Associations => New_List (
 661                Make_Attribute_Reference (Loc,
 662                  Prefix => Relocate_Node (Expression (N)),
 663                  Attribute_Name => Name_Address),
 664
 665                New_Occurrence_Of
 666                  (Node (First_Elmt (Access_Disp_Table (Iface_Typ))),
 667                   Loc))));
 668
 669          Analyze (N);
 670
 671          --  If the target is a class-wide interface we change the type of the
 672          --  data returned by IW_Convert to indicate that this is a dispatching
 673          --  call.
 674
 675          New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
 676          Set_Etype       (New_Itype, New_Itype);
 677          Init_Esize      (New_Itype);
 678          Init_Size_Align (New_Itype);
 679          Set_Directly_Designated_Type (New_Itype, Etyp);
 680
 681          Rewrite (N, Make_Explicit_Dereference (Loc,
 682                           Unchecked_Convert_To (New_Itype,
 683                             Relocate_Node (N))));
 684          Analyze (N);
 685          Freeze_Itype (New_Itype, N);
 686
 687          return;
 688       end if;
 689
 690       Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
 691       pragma Assert (Iface_Tag /= Empty);
 692
 693       --  Keep separate access types to interfaces because one internal
 694       --  function is used to handle the null value (see following comment)
 695
 696       if not Is_Access_Type (Etype (N)) then
 697          Rewrite (N,
 698            Unchecked_Convert_To (Etype (N),
 699              Make_Selected_Component (Loc,
 700                Prefix => Relocate_Node (Expression (N)),
 701                Selector_Name =>
 702                  New_Occurrence_Of (Iface_Tag, Loc))));
 703
 704       else
 705          --  Build internal function to handle the case in which the
 706          --  actual is null. If the actual is null returns null because
 707          --  no displacement is required; otherwise performs a type
 708          --  conversion that will be expanded in the code that returns
 709          --  the value of the displaced actual. That is:
 710
 711          --     function Func (O : Address) return Iface_Typ is
 712          --     begin
 713          --        if O = Null_Address then
 714          --           return null;
 715          --        else
 716          --           return Iface_Typ!(Operand_Typ!(O).Iface_Tag'Address);
 717          --        end if;
 718          --     end Func;
 719
 720          Fent := Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
 721
 722          declare
 723             Desig_Typ : Entity_Id;
 724          begin
 725             Desig_Typ := Etype (Expression (N));
 726
 727             if Is_Access_Type (Desig_Typ) then
 728                Desig_Typ := Directly_Designated_Type (Desig_Typ);
 729             end if;
 730
 731             New_Itype := Create_Itype (E_Anonymous_Access_Type, N);
 732             Set_Etype       (New_Itype, New_Itype);
 733             Set_Scope       (New_Itype, Fent);
 734             Init_Size_Align (New_Itype);
 735             Set_Directly_Designated_Type (New_Itype, Desig_Typ);
 736          end;
 737
 738          Stats := New_List (
 739            Make_Return_Statement (Loc,
 740              Unchecked_Convert_To (Etype (N),
 741                Make_Attribute_Reference (Loc,
 742                  Prefix =>
 743                    Make_Selected_Component (Loc,
 744                      Prefix => Unchecked_Convert_To (New_Itype,
 745                                  Make_Identifier (Loc, Name_uO)),
 746                      Selector_Name =>
 747                        New_Occurrence_Of (Iface_Tag, Loc)),
 748                  Attribute_Name => Name_Address))));
 749
 750          --  If the type is null-excluding, no need for the null branch.
 751          --  Otherwise we need to check for it and return null.
 752
 753          if not Can_Never_Be_Null (Etype (N)) then
 754             Stats := New_List (
 755               Make_If_Statement (Loc,
 756                Condition       =>
 757                  Make_Op_Eq (Loc,
 758                     Left_Opnd  => Make_Identifier (Loc, Name_uO),
 759                     Right_Opnd => New_Reference_To
 760                                     (RTE (RE_Null_Address), Loc)),
 761
 762               Then_Statements => New_List (
 763                 Make_Return_Statement (Loc,
 764                   Make_Null (Loc))),
 765               Else_Statements => Stats));
 766          end if;
 767
 768          Func :=
 769            Make_Subprogram_Body (Loc,
 770              Specification =>
 771                Make_Function_Specification (Loc,
 772                  Defining_Unit_Name       => Fent,
 773
 774                  Parameter_Specifications => New_List (
 775                    Make_Parameter_Specification (Loc,
 776                      Defining_Identifier =>
 777                        Make_Defining_Identifier (Loc, Name_uO),
 778                      Parameter_Type =>
 779                        New_Reference_To (RTE (RE_Address), Loc))),
 780
 781                  Result_Definition =>
 782                    New_Reference_To (Etype (N), Loc)),
 783
 784              Declarations => Empty_List,
 785
 786              Handled_Statement_Sequence =>
 787                Make_Handled_Sequence_Of_Statements (Loc, Stats));
 788
 789          --  Place function body before the expression containing the
 790          --  conversion. We suppress all checks because the body of the
 791          --  internally generated function already takes care of the case
 792          --  in which the actual is null; therefore there is no need to
 793          --  double check that the pointer is not null when the program
 794          --  executes the alternative that performs the type conversion).
 795
 796          Insert_Action (N, Func, Suppress => All_Checks);
 797
 798          if Is_Access_Type (Etype (Expression (N))) then
 799
 800             --  Generate: Operand_Typ!(Expression.all)'Address
 801
 802             Rewrite (N,
 803               Make_Function_Call (Loc,
 804                 Name => New_Reference_To (Fent, Loc),
 805                 Parameter_Associations => New_List (
 806                   Make_Attribute_Reference (Loc,
 807                     Prefix  => Unchecked_Convert_To (Operand_Typ,
 808                                  Make_Explicit_Dereference (Loc,
 809                                    Relocate_Node (Expression (N)))),
 810                     Attribute_Name => Name_Address))));
 811
 812          else
 813             --  Generate: Operand_Typ!(Expression)'Address
 814
 815             Rewrite (N,
 816               Make_Function_Call (Loc,
 817                 Name => New_Reference_To (Fent, Loc),
 818                 Parameter_Associations => New_List (
 819                   Make_Attribute_Reference (Loc,
 820                     Prefix  => Unchecked_Convert_To (Operand_Typ,
 821                                  Relocate_Node (Expression (N))),
 822                     Attribute_Name => Name_Address))));
 823          end if;
 824       end if;
 825
 826       Analyze (N);
 827    end Expand_Interface_Conversion;
 828
 829    ------------------------------
 830    -- Expand_Interface_Actuals --
 831    ------------------------------
 832
 833    procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
 834       Loc        : constant Source_Ptr := Sloc (Call_Node);
 835       Actual     : Node_Id;
 836       Actual_Dup : Node_Id;
 837       Actual_Typ : Entity_Id;
 838       Anon       : Entity_Id;
 839       Conversion : Node_Id;
 840       Formal     : Entity_Id;
 841       Formal_Typ : Entity_Id;
 842       Subp       : Entity_Id;
 843       Nam        : Name_Id;
 844       Formal_DDT : Entity_Id;
 845       Actual_DDT : Entity_Id;
 846
 847    begin
 848       --  This subprogram is called directly from the semantics, so we need a
 849       --  check to see whether expansion is active before proceeding.
 850
 851       if not Expander_Active then
 852          return;
 853       end if;
 854
 855       --  Call using access to subprogram with explicit dereference
 856
 857       if Nkind (Name (Call_Node)) = N_Explicit_Dereference then
 858          Subp := Etype (Name (Call_Node));
 859
 860       --  Normal case
 861
 862       else
 863          Subp := Entity (Name (Call_Node));
 864       end if;
 865
 866       --  Ada 2005 (AI-251): Look for interface type formals to force "this"
 867       --  displacement
 868
 869       Formal := First_Formal (Subp);
 870       Actual := First_Actual (Call_Node);
 871       while Present (Formal) loop
 872          Formal_Typ := Etype (Formal);
 873
 874          if Ekind (Formal_Typ) = E_Record_Type_With_Private then
 875             Formal_Typ := Full_View (Formal_Typ);
 876          end if;
 877
 878          if Is_Access_Type (Formal_Typ) then
 879             Formal_DDT := Directly_Designated_Type (Formal_Typ);
 880          end if;
 881
 882          Actual_Typ := Etype (Actual);
 883
 884          if Is_Access_Type (Actual_Typ) then
 885             Actual_DDT := Directly_Designated_Type (Actual_Typ);
 886          end if;
 887
 888          if Is_Interface (Formal_Typ)
 889            and then Is_Class_Wide_Type (Formal_Typ)
 890          then
 891             --  No need to displace the pointer if the type of the actual
 892             --  coindices with the type of the formal.
 893
 894             if Actual_Typ = Formal_Typ then
 895                null;
 896
 897             --  No need to displace the pointer if the interface type is
 898             --  a parent of the type of the actual because in this case the
 899             --  interface primitives are located in the primary dispatch table.
 900
 901             elsif Is_Parent (Formal_Typ, Actual_Typ) then
 902                null;
 903
 904             --  Implicit conversion to the class-wide formal type to force
 905             --  the displacement of the pointer.
 906
 907             else
 908                Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
 909                Rewrite (Actual, Conversion);
 910                Analyze_And_Resolve (Actual, Formal_Typ);
 911             end if;
 912
 913          --  Access to class-wide interface type
 914
 915          elsif Is_Access_Type (Formal_Typ)
 916            and then Is_Interface (Formal_DDT)
 917            and then Is_Class_Wide_Type (Formal_DDT)
 918            and then Interface_Present_In_Ancestor
 919                       (Typ   => Actual_DDT,
 920                        Iface => Etype (Formal_DDT))
 921          then
 922             --  Handle attributes 'Access and 'Unchecked_Access
 923
 924             if Nkind (Actual) = N_Attribute_Reference
 925               and then
 926                (Attribute_Name (Actual) = Name_Access
 927                  or else Attribute_Name (Actual) = Name_Unchecked_Access)
 928             then
 929                Nam := Attribute_Name (Actual);
 930
 931                Conversion := Convert_To (Formal_DDT, Prefix (Actual));
 932                Rewrite (Actual, Conversion);
 933                Analyze_And_Resolve (Actual, Formal_DDT);
 934
 935                Rewrite (Actual,
 936                  Unchecked_Convert_To (Formal_Typ,
 937                    Make_Attribute_Reference (Loc,
 938                      Prefix => Relocate_Node (Actual),
 939                      Attribute_Name => Nam)));
 940                Analyze_And_Resolve (Actual, Formal_Typ);
 941
 942             --  No need to displace the pointer if the type of the actual
 943             --  coincides with the type of the formal.
 944
 945             elsif Actual_DDT = Formal_DDT then
 946                null;
 947
 948             --  No need to displace the pointer if the interface type is
 949             --  a parent of the type of the actual because in this case the
 950             --  interface primitives are located in the primary dispatch table.
 951
 952             elsif Is_Parent (Formal_DDT, Actual_DDT) then
 953                null;
 954
 955             else
 956                Actual_Dup := Relocate_Node (Actual);
 957
 958                if From_With_Type (Actual_Typ) then
 959
 960                   --  If the type of the actual parameter comes from a limited
 961                   --  with-clause and the non-limited view is already available
 962                   --  we replace the anonymous access type by a duplicate decla
 963                   --  ration whose designated type is the non-limited view
 964
 965                   if Ekind (Actual_DDT) = E_Incomplete_Type
 966                     and then Present (Non_Limited_View (Actual_DDT))
 967                   then
 968                      Anon := New_Copy (Actual_Typ);
 969
 970                      if Is_Itype (Anon) then
 971                         Set_Scope (Anon, Current_Scope);
 972                      end if;
 973
 974                      Set_Directly_Designated_Type (Anon,
 975                        Non_Limited_View (Actual_DDT));
 976                      Set_Etype (Actual_Dup, Anon);
 977
 978                   elsif Is_Class_Wide_Type (Actual_DDT)
 979                     and then Ekind (Etype (Actual_DDT)) = E_Incomplete_Type
 980                     and then Present (Non_Limited_View (Etype (Actual_DDT)))
 981                   then
 982                      Anon := New_Copy (Actual_Typ);
 983
 984                      if Is_Itype (Anon) then
 985                         Set_Scope (Anon, Current_Scope);
 986                      end if;
 987
 988                      Set_Directly_Designated_Type (Anon,
 989                        New_Copy (Actual_DDT));
 990                      Set_Class_Wide_Type (Directly_Designated_Type (Anon),
 991                        New_Copy (Class_Wide_Type (Actual_DDT)));
 992                      Set_Etype (Directly_Designated_Type (Anon),
 993                        Non_Limited_View (Etype (Actual_DDT)));
 994                      Set_Etype (
 995                        Class_Wide_Type (Directly_Designated_Type (Anon)),
 996                        Non_Limited_View (Etype (Actual_DDT)));
 997                      Set_Etype (Actual_Dup, Anon);
 998                   end if;
 999                end if;
1000
1001                Conversion := Convert_To (Formal_Typ, Actual_Dup);
1002                Rewrite (Actual, Conversion);
1003                Analyze_And_Resolve (Actual, Formal_Typ);
1004             end if;
1005          end if;
1006
1007          Next_Actual (Actual);
1008          Next_Formal (Formal);
1009       end loop;
1010    end Expand_Interface_Actuals;
1011
1012    ----------------------------
1013    -- Expand_Interface_Thunk --
1014    ----------------------------
1015
1016    procedure Expand_Interface_Thunk
1017      (N           : Node_Id;
1018       Thunk_Alias : Entity_Id;
1019       Thunk_Id    : out Entity_Id;
1020       Thunk_Code  : out Node_Id)
1021    is
1022       Loc             : constant Source_Ptr := Sloc (N);
1023       Actuals         : constant List_Id    := New_List;
1024       Decl            : constant List_Id    := New_List;
1025       Formals         : constant List_Id    := New_List;
1026
1027       Controlling_Typ : Entity_Id;
1028       Decl_1          : Node_Id;
1029       Decl_2          : Node_Id;
1030       Formal          : Node_Id;
1031       Target          : Entity_Id;
1032       Target_Formal   : Entity_Id;
1033
1034    begin
1035       Thunk_Id   := Empty;
1036       Thunk_Code := Empty;
1037
1038       --  Give message if configurable run-time and Offset_To_Top unavailable
1039
1040       if not RTE_Available (RE_Offset_To_Top) then
1041          Error_Msg_CRT ("abstract interface types", N);
1042          return;
1043       end if;
1044
1045       --  Traverse the list of alias to find the final target
1046
1047       Target := Thunk_Alias;
1048       while Present (Alias (Target)) loop
1049          Target := Alias (Target);
1050       end loop;
1051
1052       --  In case of primitives that are functions without formals and
1053       --  a controlling result there is no need to build the thunk.
1054
1055       if not Present (First_Formal (Target)) then
1056          pragma Assert (Ekind (Target) = E_Function
1057            and then Has_Controlling_Result (Target));
1058          return;
1059       end if;
1060
1061       --  Duplicate the formals
1062
1063       Formal := First_Formal (Target);
1064       while Present (Formal) loop
1065          Append_To (Formals,
1066            Make_Parameter_Specification (Loc,
1067              Defining_Identifier =>
1068                Make_Defining_Identifier (Sloc (Formal),
1069                  Chars => Chars (Formal)),
1070              In_Present => In_Present (Parent (Formal)),
1071              Out_Present => Out_Present (Parent (Formal)),
1072              Parameter_Type =>
1073                New_Reference_To (Etype (Formal), Loc),
1074              Expression => New_Copy_Tree (Expression (Parent (Formal)))));
1075
1076          Next_Formal (Formal);
1077       end loop;
1078
1079       if Ekind (First_Formal (Target)) = E_In_Parameter
1080         and then Ekind (Etype (First_Formal (Target)))
1081                   = E_Anonymous_Access_Type
1082       then
1083          Controlling_Typ :=
1084            Directly_Designated_Type (Etype (First_Formal (Target)));
1085       else
1086          Controlling_Typ := Etype (First_Formal (Target));
1087       end if;
1088
1089       Target_Formal := First_Formal (Target);
1090       Formal        := First (Formals);
1091       while Present (Formal) loop
1092          if Ekind (Target_Formal) = E_In_Parameter
1093            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
1094            and then Directly_Designated_Type (Etype (Target_Formal))
1095                      = Controlling_Typ
1096          then
1097             --  Generate:
1098
1099             --     type T is access all <<type of the first formal>>
1100             --     S1 := Storage_Offset!(formal)
1101             --           - Offset_To_Top (Formal.Tag)
1102
1103             --  ... and the first actual of the call is generated as T!(S1)
1104
1105             Decl_2 :=
1106               Make_Full_Type_Declaration (Loc,
1107                 Defining_Identifier =>
1108                   Make_Defining_Identifier (Loc,
1109                     New_Internal_Name ('T')),
1110                 Type_Definition =>
1111                   Make_Access_To_Object_Definition (Loc,
1112                     All_Present            => True,
1113                     Null_Exclusion_Present => False,
1114                     Constant_Present       => False,
1115                     Subtype_Indication     =>
1116                       New_Reference_To
1117                         (Directly_Designated_Type
1118                           (Etype (Target_Formal)), Loc)));
1119
1120             Decl_1 :=
1121               Make_Object_Declaration (Loc,
1122                 Defining_Identifier =>
1123                   Make_Defining_Identifier (Loc,
1124                     New_Internal_Name ('S')),
1125                 Constant_Present    => True,
1126                 Object_Definition   =>
1127                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
1128                 Expression          =>
1129                   Make_Op_Subtract (Loc,
1130                     Left_Opnd  =>
1131                       Unchecked_Convert_To
1132                         (RTE (RE_Storage_Offset),
1133                          New_Reference_To (Defining_Identifier (Formal), Loc)),
1134                      Right_Opnd =>
1135                        Make_Function_Call (Loc,
1136                          Name =>
1137                            New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1138                          Parameter_Associations => New_List (
1139                            Unchecked_Convert_To
1140                              (RTE (RE_Address),
1141                               New_Reference_To
1142                                 (Defining_Identifier (Formal), Loc))))));
1143
1144             Append_To (Decl, Decl_2);
1145             Append_To (Decl, Decl_1);
1146
1147             --  Reference the new first actual
1148
1149             Append_To (Actuals,
1150               Unchecked_Convert_To
1151                 (Defining_Identifier (Decl_2),
1152                  New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1153
1154          elsif Etype (Target_Formal) = Controlling_Typ then
1155             --  Generate:
1156
1157             --     S1 := Storage_Offset!(Formal'Address)
1158             --           - Offset_To_Top (Formal.Tag)
1159             --     S2 := Tag_Ptr!(S3)
1160
1161             Decl_1 :=
1162               Make_Object_Declaration (Loc,
1163                 Defining_Identifier =>
1164                   Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1165                 Constant_Present    => True,
1166                 Object_Definition   =>
1167                   New_Reference_To (RTE (RE_Storage_Offset), Loc),
1168                 Expression          =>
1169                   Make_Op_Subtract (Loc,
1170                     Left_Opnd =>
1171                       Unchecked_Convert_To
1172                         (RTE (RE_Storage_Offset),
1173                          Make_Attribute_Reference (Loc,
1174                            Prefix =>
1175                              New_Reference_To
1176                                (Defining_Identifier (Formal), Loc),
1177                            Attribute_Name => Name_Address)),
1178                     Right_Opnd =>
1179                        Make_Function_Call (Loc,
1180                          Name =>
1181                            New_Reference_To (RTE (RE_Offset_To_Top), Loc),
1182                          Parameter_Associations => New_List (
1183                            Make_Attribute_Reference (Loc,
1184                              Prefix =>
1185                                New_Reference_To
1186                                  (Defining_Identifier (Formal), Loc),
1187                              Attribute_Name => Name_Address)))));
1188
1189             Decl_2 :=
1190               Make_Object_Declaration (Loc,
1191                 Defining_Identifier =>
1192                   Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
1193                 Constant_Present  => True,
1194                 Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc),
1195                 Expression        =>
1196                   Unchecked_Convert_To
1197                     (RTE (RE_Addr_Ptr),
1198                      New_Reference_To (Defining_Identifier (Decl_1), Loc)));
1199
1200             Append_To (Decl, Decl_1);
1201             Append_To (Decl, Decl_2);
1202
1203             --  Reference the new first actual
1204
1205             Append_To (Actuals,
1206               Unchecked_Convert_To
1207                 (Etype (First_Entity (Target)),
1208                  Make_Explicit_Dereference (Loc,
1209                    New_Reference_To (Defining_Identifier (Decl_2), Loc))));
1210
1211          --  No special management required for this actual
1212
1213          else
1214             Append_To (Actuals,
1215                New_Reference_To (Defining_Identifier (Formal), Loc));
1216          end if;
1217
1218          Next_Formal (Target_Formal);
1219          Next (Formal);
1220       end loop;
1221
1222       Thunk_Id :=
1223         Make_Defining_Identifier (Loc,
1224           Chars => New_Internal_Name ('T'));
1225
1226       if Ekind (Target) = E_Procedure then
1227          Thunk_Code :=
1228            Make_Subprogram_Body (Loc,
1229               Specification =>
1230                 Make_Procedure_Specification (Loc,
1231                   Defining_Unit_Name       => Thunk_Id,
1232                   Parameter_Specifications => Formals),
1233               Declarations => Decl,
1234               Handled_Statement_Sequence =>
1235                 Make_Handled_Sequence_Of_Statements (Loc,
1236                   Statements => New_List (
1237                     Make_Procedure_Call_Statement (Loc,
1238                       Name => New_Occurrence_Of (Target, Loc),
1239                       Parameter_Associations => Actuals))));
1240
1241       else pragma Assert (Ekind (Target) = E_Function);
1242
1243          Thunk_Code :=
1244            Make_Subprogram_Body (Loc,
1245               Specification =>
1246                 Make_Function_Specification (Loc,
1247                   Defining_Unit_Name       => Thunk_Id,
1248                   Parameter_Specifications => Formals,
1249                   Result_Definition =>
1250                     New_Copy (Result_Definition (Parent (Target)))),
1251               Declarations => Decl,
1252               Handled_Statement_Sequence =>
1253                 Make_Handled_Sequence_Of_Statements (Loc,
1254                   Statements => New_List (
1255                     Make_Return_Statement (Loc,
1256                       Make_Function_Call (Loc,
1257                         Name => New_Occurrence_Of (Target, Loc),
1258                         Parameter_Associations => Actuals)))));
1259       end if;
1260    end Expand_Interface_Thunk;
1261
1262    -------------------------------------
1263    -- Is_Predefined_Dispatching_Alias --
1264    -------------------------------------
1265
1266    function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean
1267    is
1268       E : Entity_Id;
1269
1270    begin
1271       if not Is_Predefined_Dispatching_Operation (Prim)
1272         and then Present (Alias (Prim))
1273       then
1274          E := Prim;
1275          while Present (Alias (E)) loop
1276             E := Alias (E);
1277          end loop;
1278
1279          if Is_Predefined_Dispatching_Operation (E) then
1280             return True;
1281          end if;
1282       end if;
1283
1284       return False;
1285    end Is_Predefined_Dispatching_Alias;
1286
1287    ----------------------------------------
1288    -- Make_Disp_Asynchronous_Select_Body --
1289    ----------------------------------------
1290
1291    function Make_Disp_Asynchronous_Select_Body
1292      (Typ : Entity_Id) return Node_Id
1293    is
1294       Com_Block : Entity_Id;
1295       Conc_Typ  : Entity_Id           := Empty;
1296       Decls     : constant List_Id    := New_List;
1297       DT_Ptr    : Entity_Id;
1298       Loc       : constant Source_Ptr := Sloc (Typ);
1299       Stmts     : constant List_Id    := New_List;
1300
1301    begin
1302       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1303
1304       --  Null body is generated for interface types
1305
1306       if Is_Interface (Typ) then
1307          return
1308            Make_Subprogram_Body (Loc,
1309              Specification =>
1310                Make_Disp_Asynchronous_Select_Spec (Typ),
1311              Declarations =>
1312                New_List,
1313              Handled_Statement_Sequence =>
1314                Make_Handled_Sequence_Of_Statements (Loc,
1315                  New_List (Make_Null_Statement (Loc))));
1316       end if;
1317
1318       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1319
1320       if Is_Concurrent_Record_Type (Typ) then
1321          Conc_Typ := Corresponding_Concurrent_Type (Typ);
1322
1323          --  Generate:
1324          --    I : Integer := Get_Entry_Index (tag! (<type>VP), S);
1325
1326          --  where I will be used to capture the entry index of the primitive
1327          --  wrapper at position S.
1328
1329          Append_To (Decls,
1330            Make_Object_Declaration (Loc,
1331              Defining_Identifier =>
1332                Make_Defining_Identifier (Loc, Name_uI),
1333              Object_Definition =>
1334                New_Reference_To (Standard_Integer, Loc),
1335              Expression =>
1336                Make_Function_Call (Loc,
1337                  Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
1338                  Parameter_Associations => New_List (
1339                    Unchecked_Convert_To (RTE (RE_Tag),
1340                      New_Reference_To (DT_Ptr, Loc)),
1341                    Make_Identifier (Loc, Name_uS)))));
1342
1343          if Ekind (Conc_Typ) = E_Protected_Type then
1344
1345             --  Generate:
1346             --    Com_Block : Communication_Block;
1347
1348             Com_Block :=
1349               Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
1350
1351             Append_To (Decls,
1352               Make_Object_Declaration (Loc,
1353                 Defining_Identifier =>
1354                   Com_Block,
1355                 Object_Definition =>
1356                   New_Reference_To (RTE (RE_Communication_Block), Loc)));
1357
1358             --  Generate:
1359             --    Protected_Entry_Call (
1360             --      T._object'access,
1361             --      protected_entry_index! (I),
1362             --      P,
1363             --      Asynchronous_Call,
1364             --      Com_Block);
1365
1366             --  where T is the protected object, I is the entry index, P are
1367             --  the wrapped parameters and B is the name of the communication
1368             --  block.
1369
1370             Append_To (Stmts,
1371               Make_Procedure_Call_Statement (Loc,
1372                 Name =>
1373                   New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
1374                 Parameter_Associations =>
1375                   New_List (
1376
1377                     Make_Attribute_Reference (Loc,        -- T._object'access
1378                       Attribute_Name =>
1379                         Name_Unchecked_Access,
1380                       Prefix =>
1381                         Make_Selected_Component (Loc,
1382                           Prefix =>
1383                             Make_Identifier (Loc, Name_uT),
1384                           Selector_Name =>
1385                             Make_Identifier (Loc, Name_uObject))),
1386
1387                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
1388                       Subtype_Mark =>
1389                         New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
1390                       Expression =>
1391                         Make_Identifier (Loc, Name_uI)),
1392
1393                     Make_Identifier (Loc, Name_uP),       --  parameter block
1394                     New_Reference_To (                    --  Asynchronous_Call
1395                       RTE (RE_Asynchronous_Call), Loc),
1396
1397                     New_Reference_To (Com_Block, Loc)))); -- comm block
1398
1399             --  Generate:
1400             --    B := Dummy_Communication_Bloc (Com_Block);
1401
1402             Append_To (Stmts,
1403               Make_Assignment_Statement (Loc,
1404                 Name =>
1405                   Make_Identifier (Loc, Name_uB),
1406                 Expression =>
1407                   Make_Unchecked_Type_Conversion (Loc,
1408                     Subtype_Mark =>
1409                       New_Reference_To (
1410                         RTE (RE_Dummy_Communication_Block), Loc),
1411                     Expression =>
1412                       New_Reference_To (Com_Block, Loc))));
1413
1414          else
1415             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
1416
1417             --  Generate:
1418             --    Protected_Entry_Call (
1419             --      T._task_id,
1420             --      task_entry_index! (I),
1421             --      P,
1422             --      Conditional_Call,
1423             --      F);
1424
1425             --  where T is the task object, I is the entry index, P are the
1426             --  wrapped parameters and F is the status flag.
1427
1428             Append_To (Stmts,
1429               Make_Procedure_Call_Statement (Loc,
1430                 Name =>
1431                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
1432                 Parameter_Associations =>
1433                   New_List (
1434
1435                     Make_Selected_Component (Loc,         -- T._task_id
1436                       Prefix =>
1437                         Make_Identifier (Loc, Name_uT),
1438                       Selector_Name =>
1439                         Make_Identifier (Loc, Name_uTask_Id)),
1440
1441                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
1442                       Subtype_Mark =>
1443                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
1444                       Expression =>
1445                         Make_Identifier (Loc, Name_uI)),
1446
1447                     Make_Identifier (Loc, Name_uP),       --  parameter block
1448                     New_Reference_To (                    --  Asynchronous_Call
1449                       RTE (RE_Asynchronous_Call), Loc),
1450                     Make_Identifier (Loc, Name_uF))));    --  status flag
1451          end if;
1452       end if;
1453
1454       return
1455         Make_Subprogram_Body (Loc,
1456           Specification =>
1457             Make_Disp_Asynchronous_Select_Spec (Typ),
1458           Declarations =>
1459             Decls,
1460           Handled_Statement_Sequence =>
1461             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
1462    end Make_Disp_Asynchronous_Select_Body;
1463
1464    ----------------------------------------
1465    -- Make_Disp_Asynchronous_Select_Spec --
1466    ----------------------------------------
1467
1468    function Make_Disp_Asynchronous_Select_Spec
1469      (Typ : Entity_Id) return Node_Id
1470    is
1471       Loc    : constant Source_Ptr := Sloc (Typ);
1472       Def_Id : constant Node_Id    :=
1473                  Make_Defining_Identifier (Loc,
1474                    Name_uDisp_Asynchronous_Select);
1475       Params : constant List_Id    := New_List;
1476
1477    begin
1478       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1479
1480       --  T : in out Typ;                     --  Object parameter
1481       --  S : Integer;                        --  Primitive operation slot
1482       --  P : Address;                        --  Wrapped parameters
1483       --  B : out Dummy_Communication_Block;  --  Communication block dummy
1484       --  F : out Boolean;                    --  Status flag
1485
1486       Append_List_To (Params, New_List (
1487
1488         Make_Parameter_Specification (Loc,
1489           Defining_Identifier =>
1490             Make_Defining_Identifier (Loc, Name_uT),
1491           Parameter_Type =>
1492             New_Reference_To (Typ, Loc),
1493           In_Present  => True,
1494           Out_Present => True),
1495
1496         Make_Parameter_Specification (Loc,
1497           Defining_Identifier =>
1498             Make_Defining_Identifier (Loc, Name_uS),
1499           Parameter_Type =>
1500             New_Reference_To (Standard_Integer, Loc)),
1501
1502         Make_Parameter_Specification (Loc,
1503           Defining_Identifier =>
1504             Make_Defining_Identifier (Loc, Name_uP),
1505           Parameter_Type =>
1506             New_Reference_To (RTE (RE_Address), Loc)),
1507
1508         Make_Parameter_Specification (Loc,
1509           Defining_Identifier =>
1510             Make_Defining_Identifier (Loc, Name_uB),
1511           Parameter_Type =>
1512             New_Reference_To (RTE (RE_Dummy_Communication_Block), Loc),
1513           Out_Present => True),
1514
1515         Make_Parameter_Specification (Loc,
1516           Defining_Identifier =>
1517             Make_Defining_Identifier (Loc, Name_uF),
1518           Parameter_Type =>
1519             New_Reference_To (Standard_Boolean, Loc),
1520           Out_Present => True)));
1521
1522       return
1523         Make_Procedure_Specification (Loc,
1524           Defining_Unit_Name       => Def_Id,
1525           Parameter_Specifications => Params);
1526    end Make_Disp_Asynchronous_Select_Spec;
1527
1528    ---------------------------------------
1529    -- Make_Disp_Conditional_Select_Body --
1530    ---------------------------------------
1531
1532    function Make_Disp_Conditional_Select_Body
1533      (Typ : Entity_Id) return Node_Id
1534    is
1535       Loc      : constant Source_Ptr := Sloc (Typ);
1536       Blk_Nam  : Entity_Id;
1537       Conc_Typ : Entity_Id           := Empty;
1538       Decls    : constant List_Id    := New_List;
1539       DT_Ptr   : Entity_Id;
1540       Stmts    : constant List_Id    := New_List;
1541
1542    begin
1543       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1544
1545       --  Null body is generated for interface types
1546
1547       if Is_Interface (Typ) then
1548          return
1549            Make_Subprogram_Body (Loc,
1550              Specification =>
1551                Make_Disp_Conditional_Select_Spec (Typ),
1552              Declarations =>
1553                No_List,
1554              Handled_Statement_Sequence =>
1555                Make_Handled_Sequence_Of_Statements (Loc,
1556                  New_List (Make_Null_Statement (Loc))));
1557       end if;
1558
1559       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1560
1561       if Is_Concurrent_Record_Type (Typ) then
1562          Conc_Typ := Corresponding_Concurrent_Type (Typ);
1563
1564          --  Generate:
1565          --    I : Integer;
1566
1567          --  where I will be used to capture the entry index of the primitive
1568          --  wrapper at position S.
1569
1570          Append_To (Decls,
1571            Make_Object_Declaration (Loc,
1572              Defining_Identifier =>
1573                Make_Defining_Identifier (Loc, Name_uI),
1574              Object_Definition =>
1575                New_Reference_To (Standard_Integer, Loc)));
1576
1577          --  Generate:
1578          --    C := Get_Prim_Op_Kind (tag! (<type>VP), S);
1579
1580          --    if C = POK_Procedure
1581          --      or else C = POK_Protected_Procedure
1582          --      or else C = POK_Task_Procedure;
1583          --    then
1584          --       F := True;
1585          --       return;
1586          --    end if;
1587
1588          Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
1589
1590          --  Generate:
1591          --    Bnn : Communication_Block;
1592
1593          --  where Bnn is the name of the communication block used in
1594          --  the call to Protected_Entry_Call.
1595
1596          Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
1597
1598          Append_To (Decls,
1599            Make_Object_Declaration (Loc,
1600              Defining_Identifier =>
1601                Blk_Nam,
1602              Object_Definition =>
1603                New_Reference_To (RTE (RE_Communication_Block), Loc)));
1604
1605          --  Generate:
1606          --    I := Get_Entry_Index (tag! (<type>VP), S);
1607
1608          --  I is the entry index and S is the dispatch table slot
1609
1610          Append_To (Stmts,
1611            Make_Assignment_Statement (Loc,
1612              Name =>
1613                Make_Identifier (Loc, Name_uI),
1614              Expression =>
1615                Make_Function_Call (Loc,
1616                  Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
1617                  Parameter_Associations => New_List (
1618                    Unchecked_Convert_To (RTE (RE_Tag),
1619                      New_Reference_To (DT_Ptr, Loc)),
1620                    Make_Identifier (Loc, Name_uS)))));
1621
1622          if Ekind (Conc_Typ) = E_Protected_Type then
1623
1624             --  Generate:
1625             --    Protected_Entry_Call (
1626             --      T._object'access,
1627             --      protected_entry_index! (I),
1628             --      P,
1629             --      Conditional_Call,
1630             --      Bnn);
1631
1632             --  where T is the protected object, I is the entry index, P are
1633             --  the wrapped parameters and Bnn is the name of the communication
1634             --  block.
1635
1636             Append_To (Stmts,
1637               Make_Procedure_Call_Statement (Loc,
1638                 Name =>
1639                   New_Reference_To (RTE (RE_Protected_Entry_Call), Loc),
1640                 Parameter_Associations =>
1641                   New_List (
1642
1643                     Make_Attribute_Reference (Loc,        -- T._object'access
1644                       Attribute_Name =>
1645                         Name_Unchecked_Access,
1646                       Prefix =>
1647                         Make_Selected_Component (Loc,
1648                           Prefix =>
1649                             Make_Identifier (Loc, Name_uT),
1650                           Selector_Name =>
1651                             Make_Identifier (Loc, Name_uObject))),
1652
1653                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
1654                       Subtype_Mark =>
1655                         New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
1656                       Expression =>
1657                         Make_Identifier (Loc, Name_uI)),
1658
1659                     Make_Identifier (Loc, Name_uP),       --  parameter block
1660                     New_Reference_To (                    --  Conditional_Call
1661                       RTE (RE_Conditional_Call), Loc),
1662                     New_Reference_To (                    --  Bnn
1663                       Blk_Nam, Loc))));
1664
1665             --  Generate:
1666             --    F := not Cancelled (Bnn);
1667
1668             --  where F is the success flag. The status of Cancelled is negated
1669             --  in order to match the behaviour of the version for task types.
1670
1671             Append_To (Stmts,
1672               Make_Assignment_Statement (Loc,
1673                 Name =>
1674                   Make_Identifier (Loc, Name_uF),
1675                 Expression =>
1676                   Make_Op_Not (Loc,
1677                     Right_Opnd =>
1678                       Make_Function_Call (Loc,
1679                         Name =>
1680                           New_Reference_To (RTE (RE_Cancelled), Loc),
1681                         Parameter_Associations =>
1682                           New_List (
1683                             New_Reference_To (Blk_Nam, Loc))))));
1684          else
1685             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
1686
1687             --  Generate:
1688             --    Protected_Entry_Call (
1689             --      T._task_id,
1690             --      task_entry_index! (I),
1691             --      P,
1692             --      Conditional_Call,
1693             --      F);
1694
1695             --  where T is the task object, I is the entry index, P are the
1696             --  wrapped parameters and F is the status flag.
1697
1698             Append_To (Stmts,
1699               Make_Procedure_Call_Statement (Loc,
1700                 Name =>
1701                   New_Reference_To (RTE (RE_Task_Entry_Call), Loc),
1702                 Parameter_Associations =>
1703                   New_List (
1704
1705                     Make_Selected_Component (Loc,         -- T._task_id
1706                       Prefix =>
1707                         Make_Identifier (Loc, Name_uT),
1708                       Selector_Name =>
1709                         Make_Identifier (Loc, Name_uTask_Id)),
1710
1711                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
1712                       Subtype_Mark =>
1713                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
1714                       Expression =>
1715                         Make_Identifier (Loc, Name_uI)),
1716
1717                     Make_Identifier (Loc, Name_uP),       --  parameter block
1718                     New_Reference_To (                    --  Conditional_Call
1719                       RTE (RE_Conditional_Call), Loc),
1720                     Make_Identifier (Loc, Name_uF))));    --  status flag
1721          end if;
1722       end if;
1723
1724       return
1725         Make_Subprogram_Body (Loc,
1726           Specification =>
1727             Make_Disp_Conditional_Select_Spec (Typ),
1728           Declarations =>
1729             Decls,
1730           Handled_Statement_Sequence =>
1731             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
1732    end Make_Disp_Conditional_Select_Body;
1733
1734    ---------------------------------------
1735    -- Make_Disp_Conditional_Select_Spec --
1736    ---------------------------------------
1737
1738    function Make_Disp_Conditional_Select_Spec
1739      (Typ : Entity_Id) return Node_Id
1740    is
1741       Loc    : constant Source_Ptr := Sloc (Typ);
1742       Def_Id : constant Node_Id    :=
1743                  Make_Defining_Identifier (Loc,
1744                    Name_uDisp_Conditional_Select);
1745       Params : constant List_Id    := New_List;
1746
1747    begin
1748       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1749
1750       --  T : in out Typ;        --  Object parameter
1751       --  S : Integer;           --  Primitive operation slot
1752       --  P : Address;           --  Wrapped parameters
1753       --  C : out Prim_Op_Kind;  --  Call kind
1754       --  F : out Boolean;       --  Status flag
1755
1756       Append_List_To (Params, New_List (
1757
1758         Make_Parameter_Specification (Loc,
1759           Defining_Identifier =>
1760             Make_Defining_Identifier (Loc, Name_uT),
1761           Parameter_Type =>
1762             New_Reference_To (Typ, Loc),
1763           In_Present  => True,
1764           Out_Present => True),
1765
1766         Make_Parameter_Specification (Loc,
1767           Defining_Identifier =>
1768             Make_Defining_Identifier (Loc, Name_uS),
1769           Parameter_Type =>
1770             New_Reference_To (Standard_Integer, Loc)),
1771
1772         Make_Parameter_Specification (Loc,
1773           Defining_Identifier =>
1774             Make_Defining_Identifier (Loc, Name_uP),
1775           Parameter_Type =>
1776             New_Reference_To (RTE (RE_Address), Loc)),
1777
1778         Make_Parameter_Specification (Loc,
1779           Defining_Identifier =>
1780             Make_Defining_Identifier (Loc, Name_uC),
1781           Parameter_Type =>
1782             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
1783           Out_Present => True),
1784
1785         Make_Parameter_Specification (Loc,
1786           Defining_Identifier =>
1787             Make_Defining_Identifier (Loc, Name_uF),
1788           Parameter_Type =>
1789             New_Reference_To (Standard_Boolean, Loc),
1790           Out_Present => True)));
1791
1792       return
1793         Make_Procedure_Specification (Loc,
1794           Defining_Unit_Name       => Def_Id,
1795           Parameter_Specifications => Params);
1796    end Make_Disp_Conditional_Select_Spec;
1797
1798    -------------------------------------
1799    -- Make_Disp_Get_Prim_Op_Kind_Body --
1800    -------------------------------------
1801
1802    function Make_Disp_Get_Prim_Op_Kind_Body
1803      (Typ : Entity_Id) return Node_Id
1804    is
1805       Loc    : constant Source_Ptr := Sloc (Typ);
1806       DT_Ptr : Entity_Id;
1807
1808    begin
1809       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1810
1811       if Is_Interface (Typ) then
1812          return
1813            Make_Subprogram_Body (Loc,
1814              Specification =>
1815                Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
1816              Declarations =>
1817                New_List,
1818              Handled_Statement_Sequence =>
1819                Make_Handled_Sequence_Of_Statements (Loc,
1820                  New_List (Make_Null_Statement (Loc))));
1821       end if;
1822
1823       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
1824
1825       --  Generate:
1826       --    C := get_prim_op_kind (tag! (<type>VP), S);
1827
1828       --  where C is the out parameter capturing the call kind and S is the
1829       --  dispatch table slot number.
1830
1831       return
1832         Make_Subprogram_Body (Loc,
1833           Specification =>
1834             Make_Disp_Get_Prim_Op_Kind_Spec (Typ),
1835           Declarations =>
1836             New_List,
1837           Handled_Statement_Sequence =>
1838             Make_Handled_Sequence_Of_Statements (Loc,
1839               New_List (
1840                 Make_Assignment_Statement (Loc,
1841                   Name =>
1842                     Make_Identifier (Loc, Name_uC),
1843                   Expression =>
1844                     Make_Function_Call (Loc,
1845                       Name =>
1846                         New_Reference_To (RTE (RE_Get_Prim_Op_Kind), Loc),
1847                       Parameter_Associations => New_List (
1848                         Unchecked_Convert_To (RTE (RE_Tag),
1849                           New_Reference_To (DT_Ptr, Loc)),
1850                           Make_Identifier (Loc, Name_uS)))))));
1851    end Make_Disp_Get_Prim_Op_Kind_Body;
1852
1853    -------------------------------------
1854    -- Make_Disp_Get_Prim_Op_Kind_Spec --
1855    -------------------------------------
1856
1857    function Make_Disp_Get_Prim_Op_Kind_Spec
1858      (Typ : Entity_Id) return Node_Id
1859    is
1860       Loc    : constant Source_Ptr := Sloc (Typ);
1861       Def_Id : constant Node_Id    :=
1862                  Make_Defining_Identifier (Loc,
1863                    Name_uDisp_Get_Prim_Op_Kind);
1864       Params : constant List_Id    := New_List;
1865
1866    begin
1867       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1868
1869       --  T : in out Typ;       --  Object parameter
1870       --  S : Integer;          --  Primitive operation slot
1871       --  C : out Prim_Op_Kind; --  Call kind
1872
1873       Append_List_To (Params, New_List (
1874
1875         Make_Parameter_Specification (Loc,
1876           Defining_Identifier =>
1877             Make_Defining_Identifier (Loc, Name_uT),
1878           Parameter_Type =>
1879             New_Reference_To (Typ, Loc),
1880           In_Present  => True,
1881           Out_Present => True),
1882
1883         Make_Parameter_Specification (Loc,
1884           Defining_Identifier =>
1885             Make_Defining_Identifier (Loc, Name_uS),
1886           Parameter_Type =>
1887             New_Reference_To (Standard_Integer, Loc)),
1888
1889         Make_Parameter_Specification (Loc,
1890           Defining_Identifier =>
1891             Make_Defining_Identifier (Loc, Name_uC),
1892           Parameter_Type =>
1893             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
1894           Out_Present => True)));
1895
1896       return
1897         Make_Procedure_Specification (Loc,
1898            Defining_Unit_Name       => Def_Id,
1899            Parameter_Specifications => Params);
1900    end Make_Disp_Get_Prim_Op_Kind_Spec;
1901
1902    --------------------------------
1903    -- Make_Disp_Get_Task_Id_Body --
1904    --------------------------------
1905
1906    function Make_Disp_Get_Task_Id_Body
1907      (Typ : Entity_Id) return Node_Id
1908    is
1909       Loc : constant Source_Ptr := Sloc (Typ);
1910       Ret : Node_Id;
1911
1912    begin
1913       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1914
1915       if Is_Concurrent_Record_Type (Typ)
1916         and then Ekind (Corresponding_Concurrent_Type (Typ)) = E_Task_Type
1917       then
1918          --  Generate:
1919          --    return To_Address (_T._task_id);
1920
1921          Ret :=
1922            Make_Return_Statement (Loc,
1923              Expression =>
1924                Make_Unchecked_Type_Conversion (Loc,
1925                  Subtype_Mark =>
1926                    New_Reference_To (RTE (RE_Address), Loc),
1927                  Expression =>
1928                    Make_Selected_Component (Loc,
1929                      Prefix =>
1930                        Make_Identifier (Loc, Name_uT),
1931                      Selector_Name =>
1932                        Make_Identifier (Loc, Name_uTask_Id))));
1933
1934       --  A null body is constructed for non-task types
1935
1936       else
1937          --  Generate:
1938          --    return Null_Address;
1939
1940          Ret :=
1941            Make_Return_Statement (Loc,
1942              Expression =>
1943                New_Reference_To (RTE (RE_Null_Address), Loc));
1944       end if;
1945
1946       return
1947         Make_Subprogram_Body (Loc,
1948           Specification =>
1949             Make_Disp_Get_Task_Id_Spec (Typ),
1950           Declarations =>
1951             New_List,
1952           Handled_Statement_Sequence =>
1953             Make_Handled_Sequence_Of_Statements (Loc,
1954               New_List (Ret)));
1955    end Make_Disp_Get_Task_Id_Body;
1956
1957    --------------------------------
1958    -- Make_Disp_Get_Task_Id_Spec --
1959    --------------------------------
1960
1961    function Make_Disp_Get_Task_Id_Spec
1962      (Typ : Entity_Id) return Node_Id
1963    is
1964       Loc : constant Source_Ptr := Sloc (Typ);
1965
1966    begin
1967       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1968
1969       return
1970         Make_Function_Specification (Loc,
1971           Defining_Unit_Name =>
1972             Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id),
1973           Parameter_Specifications => New_List (
1974             Make_Parameter_Specification (Loc,
1975               Defining_Identifier =>
1976                 Make_Defining_Identifier (Loc, Name_uT),
1977               Parameter_Type =>
1978                 New_Reference_To (Typ, Loc))),
1979           Result_Definition =>
1980             New_Reference_To (RTE (RE_Address), Loc));
1981    end Make_Disp_Get_Task_Id_Spec;
1982
1983    ---------------------------------
1984    -- Make_Disp_Timed_Select_Body --
1985    ---------------------------------
1986
1987    function Make_Disp_Timed_Select_Body
1988      (Typ : Entity_Id) return Node_Id
1989    is
1990       Loc      : constant Source_Ptr := Sloc (Typ);
1991       Conc_Typ : Entity_Id           := Empty;
1992       Decls    : constant List_Id    := New_List;
1993       DT_Ptr   : Entity_Id;
1994       Stmts    : constant List_Id    := New_List;
1995
1996    begin
1997       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
1998
1999       --  Null body is generated for interface types
2000
2001       if Is_Interface (Typ) then
2002          return
2003            Make_Subprogram_Body (Loc,
2004              Specification =>
2005                Make_Disp_Timed_Select_Spec (Typ),
2006              Declarations =>
2007                New_List,
2008              Handled_Statement_Sequence =>
2009                Make_Handled_Sequence_Of_Statements (Loc,
2010                  New_List (Make_Null_Statement (Loc))));
2011       end if;
2012
2013       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2014
2015       if Is_Concurrent_Record_Type (Typ) then
2016          Conc_Typ := Corresponding_Concurrent_Type (Typ);
2017
2018          --  Generate:
2019          --    I : Integer;
2020
2021          --  where I will be used to capture the entry index of the primitive
2022          --  wrapper at position S.
2023
2024          Append_To (Decls,
2025            Make_Object_Declaration (Loc,
2026              Defining_Identifier =>
2027                Make_Defining_Identifier (Loc, Name_uI),
2028              Object_Definition =>
2029                New_Reference_To (Standard_Integer, Loc)));
2030
2031          --  Generate:
2032          --    C := Get_Prim_Op_Kind (tag! (<type>VP), S);
2033
2034          --    if C = POK_Procedure
2035          --      or else C = POK_Protected_Procedure
2036          --      or else C = POK_Task_Procedure;
2037          --    then
2038          --       F := True;
2039          --       return;
2040          --    end if;
2041
2042          Build_Common_Dispatching_Select_Statements (Loc, DT_Ptr, Stmts);
2043
2044          --  Generate:
2045          --    I := Get_Entry_Index (tag! (<type>VP), S);
2046
2047          --  I is the entry index and S is the dispatch table slot
2048
2049          Append_To (Stmts,
2050            Make_Assignment_Statement (Loc,
2051              Name =>
2052                Make_Identifier (Loc, Name_uI),
2053              Expression =>
2054                Make_Function_Call (Loc,
2055                  Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
2056                  Parameter_Associations => New_List (
2057                    Unchecked_Convert_To (RTE (RE_Tag),
2058                      New_Reference_To (DT_Ptr, Loc)),
2059                    Make_Identifier (Loc, Name_uS)))));
2060
2061          if Ekind (Conc_Typ) = E_Protected_Type then
2062
2063             --  Generate:
2064             --    Timed_Protected_Entry_Call (
2065             --      T._object'access,
2066             --      protected_entry_index! (I),
2067             --      P,
2068             --      D,
2069             --      M,
2070             --      F);
2071
2072             --  where T is the protected object, I is the entry index, P are
2073             --  the wrapped parameters, D is the delay amount, M is the delay
2074             --  mode and F is the status flag.
2075
2076             Append_To (Stmts,
2077               Make_Procedure_Call_Statement (Loc,
2078                 Name =>
2079                   New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc),
2080                 Parameter_Associations =>
2081                   New_List (
2082
2083                     Make_Attribute_Reference (Loc,        -- T._object'access
2084                       Attribute_Name =>
2085                         Name_Unchecked_Access,
2086                       Prefix =>
2087                         Make_Selected_Component (Loc,
2088                           Prefix =>
2089                             Make_Identifier (Loc, Name_uT),
2090                           Selector_Name =>
2091                             Make_Identifier (Loc, Name_uObject))),
2092
2093                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2094                       Subtype_Mark =>
2095                         New_Reference_To (RTE (RE_Protected_Entry_Index), Loc),
2096                       Expression =>
2097                         Make_Identifier (Loc, Name_uI)),
2098
2099                     Make_Identifier (Loc, Name_uP),       --  parameter block
2100                     Make_Identifier (Loc, Name_uD),       --  delay
2101                     Make_Identifier (Loc, Name_uM),       --  delay mode
2102                     Make_Identifier (Loc, Name_uF))));    --  status flag
2103
2104          else
2105             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
2106
2107             --  Generate:
2108             --    Timed_Task_Entry_Call (
2109             --      T._task_id,
2110             --      task_entry_index! (I),
2111             --      P,
2112             --      D,
2113             --      M,
2114             --      F);
2115
2116             --  where T is the task object, I is the entry index, P are the
2117             --  wrapped parameters, D is the delay amount, M is the delay
2118             --  mode and F is the status flag.
2119
2120             Append_To (Stmts,
2121               Make_Procedure_Call_Statement (Loc,
2122                 Name =>
2123                   New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc),
2124                 Parameter_Associations =>
2125                   New_List (
2126
2127                     Make_Selected_Component (Loc,         --  T._task_id
2128                       Prefix =>
2129                         Make_Identifier (Loc, Name_uT),
2130                       Selector_Name =>
2131                         Make_Identifier (Loc, Name_uTask_Id)),
2132
2133                     Make_Unchecked_Type_Conversion (Loc,  --  entry index
2134                       Subtype_Mark =>
2135                         New_Reference_To (RTE (RE_Task_Entry_Index), Loc),
2136                       Expression =>
2137                         Make_Identifier (Loc, Name_uI)),
2138
2139                     Make_Identifier (Loc, Name_uP),       --  parameter block
2140                     Make_Identifier (Loc, Name_uD),       --  delay
2141                     Make_Identifier (Loc, Name_uM),       --  delay mode
2142                     Make_Identifier (Loc, Name_uF))));    --  status flag
2143          end if;
2144       end if;
2145
2146       return
2147         Make_Subprogram_Body (Loc,
2148           Specification =>
2149             Make_Disp_Timed_Select_Spec (Typ),
2150           Declarations =>
2151             Decls,
2152           Handled_Statement_Sequence =>
2153             Make_Handled_Sequence_Of_Statements (Loc, Stmts));
2154    end Make_Disp_Timed_Select_Body;
2155
2156    ---------------------------------
2157    -- Make_Disp_Timed_Select_Spec --
2158    ---------------------------------
2159
2160    function Make_Disp_Timed_Select_Spec
2161      (Typ : Entity_Id) return Node_Id
2162    is
2163       Loc    : constant Source_Ptr := Sloc (Typ);
2164       Def_Id : constant Node_Id    :=
2165                  Make_Defining_Identifier (Loc,
2166                    Name_uDisp_Timed_Select);
2167       Params : constant List_Id    := New_List;
2168
2169    begin
2170       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
2171
2172       --  T : in out Typ;        --  Object parameter
2173       --  S : Integer;           --  Primitive operation slot
2174       --  P : Address;           --  Wrapped parameters
2175       --  D : Duration;          --  Delay
2176       --  M : Integer;           --  Delay Mode
2177       --  C : out Prim_Op_Kind;  --  Call kind
2178       --  F : out Boolean;       --  Status flag
2179
2180       Append_List_To (Params, New_List (
2181
2182         Make_Parameter_Specification (Loc,
2183           Defining_Identifier =>
2184             Make_Defining_Identifier (Loc, Name_uT),
2185           Parameter_Type =>
2186             New_Reference_To (Typ, Loc),
2187           In_Present  => True,
2188           Out_Present => True),
2189
2190         Make_Parameter_Specification (Loc,
2191           Defining_Identifier =>
2192             Make_Defining_Identifier (Loc, Name_uS),
2193           Parameter_Type =>
2194             New_Reference_To (Standard_Integer, Loc)),
2195
2196         Make_Parameter_Specification (Loc,
2197           Defining_Identifier =>
2198             Make_Defining_Identifier (Loc, Name_uP),
2199           Parameter_Type =>
2200             New_Reference_To (RTE (RE_Address), Loc)),
2201
2202         Make_Parameter_Specification (Loc,
2203           Defining_Identifier =>
2204             Make_Defining_Identifier (Loc, Name_uD),
2205           Parameter_Type =>
2206             New_Reference_To (Standard_Duration, Loc)),
2207
2208         Make_Parameter_Specification (Loc,
2209           Defining_Identifier =>
2210             Make_Defining_Identifier (Loc, Name_uM),
2211           Parameter_Type =>
2212             New_Reference_To (Standard_Integer, Loc)),
2213
2214         Make_Parameter_Specification (Loc,
2215           Defining_Identifier =>
2216             Make_Defining_Identifier (Loc, Name_uC),
2217           Parameter_Type =>
2218             New_Reference_To (RTE (RE_Prim_Op_Kind), Loc),
2219           Out_Present => True)));
2220
2221       Append_To (Params,
2222         Make_Parameter_Specification (Loc,
2223           Defining_Identifier =>
2224             Make_Defining_Identifier (Loc, Name_uF),
2225           Parameter_Type =>
2226             New_Reference_To (Standard_Boolean, Loc),
2227           Out_Present => True));
2228
2229       return
2230         Make_Procedure_Specification (Loc,
2231           Defining_Unit_Name       => Def_Id,
2232           Parameter_Specifications => Params);
2233    end Make_Disp_Timed_Select_Spec;
2234
2235    -------------
2236    -- Make_DT --
2237    -------------
2238
2239    --  The frontend supports two models for expanding dispatch tables
2240    --  associated with library-level defined tagged types: statically
2241    --  and non-statically allocated dispatch tables. In the former case
2242    --  the object containing the dispatch table is constant and it is
2243    --  initialized by means of a positional aggregate. In the latter case,
2244    --  the object containing the dispatch table is a variable which is
2245    --  initialized by means of assignments.
2246
2247    --  In case of locally defined tagged types, the object containing the
2248    --  object containing the dispatch table is always a variable (instead
2249    --  of a constant). This is currently required to give support to late
2250    --  overriding of primitives. For example:
2251
2252    --     procedure Example is
2253    --        package Pkg is
2254    --           type T1 is tagged null record;
2255    --           procedure Prim (O : T1);
2256    --        end Pkg;
2257
2258    --        type T2 is new Pkg.T1 with null record;
2259    --        procedure Prim (X : T2) is    -- late overriding
2260    --        begin
2261    --           ...
2262    --     ...
2263    --     end;
2264
2265    function Make_DT (Typ : Entity_Id) return List_Id is
2266       Loc              : constant Source_Ptr := Sloc (Typ);
2267       Is_Local_DT      : constant Boolean :=
2268                            Ekind (Cunit_Entity (Get_Source_Unit (Typ)))
2269                              /= E_Package;
2270       Max_Predef_Prims : constant Int :=
2271                            UI_To_Int
2272                              (Intval
2273                                (Expression
2274                                  (Parent (RTE (RE_Default_Prim_Op_Count)))));
2275
2276       procedure Make_Secondary_DT
2277         (Typ             : Entity_Id;
2278          Iface           : Entity_Id;
2279          AI_Tag          : Entity_Id;
2280          Iface_DT_Ptr    : Entity_Id;
2281          Result          : List_Id);
2282       --  Ada 2005 (AI-251): Expand the declarations for the Secondary Dispatch
2283       --  Table of Typ associated with Iface (each abstract interface of Typ
2284       --  has a secondary dispatch table). The arguments Typ, Ancestor_Typ
2285       --  and Suffix_Index are used to generate an unique external name which
2286       --  is added at the end of Acc_Disp_Tables; this external name will be
2287       --  used later by the subprogram Exp_Ch3.Build_Init_Procedure.
2288
2289       -----------------------
2290       -- Make_Secondary_DT --
2291       -----------------------
2292
2293       procedure Make_Secondary_DT
2294         (Typ          : Entity_Id;
2295          Iface        : Entity_Id;
2296          AI_Tag       : Entity_Id;
2297          Iface_DT_Ptr : Entity_Id;
2298          Result       : List_Id)
2299       is
2300          Loc                : constant Source_Ptr := Sloc (Typ);
2301          Generalized_Tag    : constant Entity_Id := RTE (RE_Interface_Tag);
2302
2303          Name_DT            : constant Name_Id := New_Internal_Name ('T');
2304          Iface_DT           : constant Entity_Id :=
2305                                 Make_Defining_Identifier (Loc, Name_DT);
2306          Name_Predef_Prims  : constant Name_Id := New_Internal_Name ('R');
2307          Predef_Prims       : constant Entity_Id :=
2308                                 Make_Defining_Identifier (Loc,
2309                                   Name_Predef_Prims);
2310          DT_Constr_List     : List_Id;
2311          DT_Aggr_List       : List_Id;
2312          Empty_DT           : Boolean := False;
2313          Nb_Predef_Prims    : Nat := 0;
2314          Nb_Prim            : Nat;
2315          New_Node           : Node_Id;
2316          OSD                : Entity_Id;
2317          OSD_Aggr_List      : List_Id;
2318          Pos                : Nat;
2319          Prim               : Entity_Id;
2320          Prim_Elmt          : Elmt_Id;
2321          Prim_Ops_Aggr_List : List_Id;
2322
2323       begin
2324          --  Handle the case where the backend does not support statically
2325          --  allocated dispatch tables.
2326
2327          if not Static_Dispatch_Tables
2328            or else Is_Local_DT
2329          then
2330             Set_Ekind (Predef_Prims, E_Variable);
2331             Set_Is_Statically_Allocated (Predef_Prims);
2332
2333             Set_Ekind (Iface_DT, E_Variable);
2334             Set_Is_Statically_Allocated (Iface_DT);
2335
2336          --  Statically allocated dispatch tables and related entities are
2337          --  constants.
2338
2339          else
2340             Set_Ekind (Predef_Prims, E_Constant);
2341             Set_Is_Statically_Allocated (Predef_Prims);
2342             Set_Is_True_Constant (Predef_Prims);
2343
2344             Set_Ekind (Iface_DT, E_Constant);
2345             Set_Is_Statically_Allocated (Iface_DT);
2346             Set_Is_True_Constant (Iface_DT);
2347          end if;
2348
2349          --  Generate code to create the storage for the Dispatch_Table object.
2350          --  If the number of primitives of Typ is 0 we reserve a dummy single
2351          --  entry for its DT because at run-time the pointer to this dummy
2352          --  entry will be used as the tag.
2353
2354          Nb_Prim := UI_To_Int (DT_Entry_Count (AI_Tag));
2355
2356          if Nb_Prim = 0 then
2357             Empty_DT := True;
2358             Nb_Prim  := 1;
2359          end if;
2360
2361          --  Generate:
2362
2363          --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
2364          --                    (predef-prim-op-thunk-1'address,
2365          --                     predef-prim-op-thunk-2'address,
2366          --                     ...
2367          --                     predef-prim-op-thunk-n'address);
2368          --   for Predef_Prims'Alignment use Address'Alignment
2369
2370          --  Stage 1: Calculate the number of predefined primitives
2371
2372          if not Static_Dispatch_Tables then
2373             Nb_Predef_Prims := Max_Predef_Prims;
2374          else
2375             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2376             while Present (Prim_Elmt) loop
2377                Prim := Node (Prim_Elmt);
2378
2379                if Is_Predefined_Dispatching_Operation (Prim)
2380                  and then not Is_Abstract_Subprogram (Prim)
2381                then
2382                   Pos := UI_To_Int (DT_Position (Prim));
2383
2384                   if Pos > Nb_Predef_Prims then
2385                      Nb_Predef_Prims := Pos;
2386                   end if;
2387                end if;
2388
2389                Next_Elmt (Prim_Elmt);
2390             end loop;
2391          end if;
2392
2393          --  Stage 2: Create the thunks associated with the predefined
2394          --  primitives and save their entity to fill the aggregate.
2395
2396          declare
2397             Prim_Table : array (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
2398             Thunk_Id   : Entity_Id;
2399             Thunk_Code : Node_Id;
2400
2401          begin
2402             Prim_Ops_Aggr_List := New_List;
2403             Prim_Table := (others => Empty);
2404
2405             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2406             while Present (Prim_Elmt) loop
2407                Prim := Node (Prim_Elmt);
2408
2409                if Is_Predefined_Dispatching_Operation (Prim)
2410                  and then not Is_Abstract_Subprogram (Prim)
2411                  and then not Present (Prim_Table
2412                                         (UI_To_Int (DT_Position (Prim))))
2413                then
2414                   while Present (Alias (Prim)) loop
2415                      Prim := Alias (Prim);
2416                   end loop;
2417
2418                   Expand_Interface_Thunk
2419                     (N           => Prim,
2420                      Thunk_Alias => Prim,
2421                      Thunk_Id    => Thunk_Id,
2422                      Thunk_Code  => Thunk_Code);
2423
2424                   if Present (Thunk_Id) then
2425                      Append_To (Result, Thunk_Code);
2426                      Prim_Table (UI_To_Int (DT_Position (Prim))) := Thunk_Id;
2427                   end if;
2428                end if;
2429
2430                Next_Elmt (Prim_Elmt);
2431             end loop;
2432
2433             for J in Prim_Table'Range loop
2434                if Present (Prim_Table (J)) then
2435                   New_Node :=
2436                     Make_Attribute_Reference (Loc,
2437                       Prefix => New_Reference_To (Prim_Table (J), Loc),
2438                       Attribute_Name => Name_Address);
2439                else
2440                   New_Node :=
2441                     New_Reference_To (RTE (RE_Null_Address), Loc);
2442                end if;
2443
2444                Append_To (Prim_Ops_Aggr_List, New_Node);
2445             end loop;
2446
2447             Append_To (Result,
2448               Make_Object_Declaration (Loc,
2449                 Defining_Identifier => Predef_Prims,
2450                 Constant_Present    => Static_Dispatch_Tables,
2451                 Aliased_Present     => True,
2452                 Object_Definition   =>
2453                   New_Reference_To (RTE (RE_Address_Array), Loc),
2454                 Expression => Make_Aggregate (Loc,
2455                   Expressions => Prim_Ops_Aggr_List)));
2456
2457             Append_To (Result,
2458               Make_Attribute_Definition_Clause (Loc,
2459                 Name       => New_Reference_To (Predef_Prims, Loc),
2460                 Chars      => Name_Alignment,
2461                 Expression =>
2462                   Make_Attribute_Reference (Loc,
2463                     Prefix =>
2464                       New_Reference_To (RTE (RE_Integer_Address), Loc),
2465                     Attribute_Name => Name_Alignment)));
2466          end;
2467
2468          --  Generate
2469
2470          --   OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) :=
2471          --          (OSD_Table => (1 => <value>,
2472          --                           ...
2473          --                         N => <value>));
2474
2475          --   Iface_DT : Dispatch_Table (Nb_Prims) :=
2476          --               ([ Signature   => <sig-value> ],
2477          --                Tag_Kind      => <tag_kind-value>,
2478          --                Predef_Prims  => Predef_Prims'Address,
2479          --                Offset_To_Top => 0,
2480          --                OSD           => OSD'Address,
2481          --                Prims_Ptr     => (prim-op-1'address,
2482          --                                  prim-op-2'address,
2483          --                                  ...
2484          --                                  prim-op-n'address));
2485
2486          --  Stage 3: Initialize the discriminant and the record components
2487
2488          DT_Constr_List := New_List;
2489          DT_Aggr_List   := New_List;
2490
2491          --  Nb_Prim. If the tagged type has no primitives we add a dummy
2492          --  slot whose address will be the tag of this type.
2493
2494          if Nb_Prim = 0 then
2495             New_Node := Make_Integer_Literal (Loc, 1);
2496          else
2497             New_Node := Make_Integer_Literal (Loc, Nb_Prim);
2498          end if;
2499
2500          Append_To (DT_Constr_List, New_Node);
2501          Append_To (DT_Aggr_List, New_Copy (New_Node));
2502
2503          --  Signature
2504
2505          if RTE_Record_Component_Available (RE_Signature) then
2506             Append_To (DT_Aggr_List,
2507               New_Reference_To (RTE (RE_Secondary_DT), Loc));
2508          end if;
2509
2510          --  Tag_Kind
2511
2512          if RTE_Record_Component_Available (RE_Tag_Kind) then
2513             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
2514          end if;
2515
2516          --  Predef_Prims
2517
2518          Append_To (DT_Aggr_List,
2519            Make_Attribute_Reference (Loc,
2520              Prefix => New_Reference_To (Predef_Prims, Loc),
2521              Attribute_Name => Name_Address));
2522
2523          --  Note: The correct value of Offset_To_Top will be set by the init
2524          --  subprogram
2525
2526          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
2527
2528          --  Generate the Object Specific Data table required to dispatch calls
2529          --  through synchronized interfaces.
2530
2531          if Empty_DT
2532            or else Is_Abstract_Type (Typ)
2533            or else Is_Controlled (Typ)
2534            or else Restriction_Active (No_Dispatching_Calls)
2535            or else not Is_Limited_Type (Typ)
2536            or else not Has_Abstract_Interfaces (Typ)
2537          then
2538             --  No OSD table required
2539
2540             Append_To (DT_Aggr_List,
2541               New_Reference_To (RTE (RE_Null_Address), Loc));
2542
2543          else
2544             OSD_Aggr_List := New_List;
2545
2546             declare
2547                Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
2548                Prim       : Entity_Id;
2549                Prim_Alias : Entity_Id;
2550                Prim_Elmt  : Elmt_Id;
2551                E          : Entity_Id;
2552                Count      : Nat := 0;
2553                Pos        : Nat;
2554
2555             begin
2556                Prim_Table := (others => Empty);
2557                Prim_Alias := Empty;
2558
2559                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2560                while Present (Prim_Elmt) loop
2561                   Prim := Node (Prim_Elmt);
2562
2563                   if Present (Abstract_Interface_Alias (Prim))
2564                     and then Find_Dispatching_Type
2565                                (Abstract_Interface_Alias (Prim)) = Iface
2566                   then
2567                      Prim_Alias := Abstract_Interface_Alias (Prim);
2568
2569                      E := Prim;
2570                      while Present (Alias (E)) loop
2571                         E := Alias (E);
2572                      end loop;
2573
2574                      Pos := UI_To_Int (DT_Position (Prim_Alias));
2575
2576                      if Present (Prim_Table (Pos)) then
2577                         pragma Assert (Prim_Table (Pos) = E);
2578                         null;
2579
2580                      else
2581                         Prim_Table (Pos) := E;
2582
2583                         Append_To (OSD_Aggr_List,
2584                           Make_Component_Association (Loc,
2585                             Choices => New_List (
2586                               Make_Integer_Literal (Loc,
2587                                 DT_Position (Prim_Alias))),
2588                             Expression =>
2589                               Make_Integer_Literal (Loc,
2590                                 DT_Position (Alias (Prim)))));
2591
2592                         Count := Count + 1;
2593                      end if;
2594                   end if;
2595
2596                   Next_Elmt (Prim_Elmt);
2597                end loop;
2598                pragma Assert (Count = Nb_Prim);
2599             end;
2600
2601             OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
2602
2603             Append_To (Result,
2604               Make_Object_Declaration (Loc,
2605                 Defining_Identifier => OSD,
2606                 Object_Definition   =>
2607                   Make_Subtype_Indication (Loc,
2608                     Subtype_Mark =>
2609                       New_Reference_To (RTE (RE_Object_Specific_Data), Loc),
2610                     Constraint =>
2611                       Make_Index_Or_Discriminant_Constraint (Loc,
2612                         Constraints => New_List (
2613                           Make_Integer_Literal (Loc, Nb_Prim)))),
2614                 Expression => Make_Aggregate (Loc,
2615                   Component_Associations => New_List (
2616                     Make_Component_Association (Loc,
2617                       Choices => New_List (
2618                         New_Occurrence_Of
2619                           (RTE_Record_Component (RE_OSD_Num_Prims), Loc)),
2620                       Expression =>
2621                         Make_Integer_Literal (Loc, Nb_Prim)),
2622
2623                     Make_Component_Association (Loc,
2624                       Choices => New_List (
2625                         New_Occurrence_Of
2626                           (RTE_Record_Component (RE_OSD_Table), Loc)),
2627                       Expression => Make_Aggregate (Loc,
2628                         Component_Associations => OSD_Aggr_List))))));
2629
2630             --  In secondary dispatch tables the Typeinfo component contains
2631             --  the address of the Object Specific Data (see a-tags.ads)
2632
2633             Append_To (DT_Aggr_List,
2634               Make_Attribute_Reference (Loc,
2635                 Prefix => New_Reference_To (OSD, Loc),
2636                 Attribute_Name => Name_Address));
2637          end if;
2638
2639          --  Initialize the table of primitive operations
2640
2641          Prim_Ops_Aggr_List := New_List;
2642
2643          if Empty_DT then
2644             Append_To (Prim_Ops_Aggr_List,
2645               New_Reference_To (RTE (RE_Null_Address), Loc));
2646
2647          elsif Is_Abstract_Type (Typ)
2648            or else not Static_Dispatch_Tables
2649          then
2650             for J in 1 .. Nb_Prim loop
2651                Append_To (Prim_Ops_Aggr_List,
2652                  New_Reference_To (RTE (RE_Null_Address), Loc));
2653             end loop;
2654
2655          else
2656             declare
2657                Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
2658                Pos        : Nat;
2659                Thunk_Code : Node_Id;
2660                Thunk_Id   : Entity_Id;
2661
2662             begin
2663                Prim_Table := (others => Empty);
2664
2665                Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
2666                while Present (Prim_Elmt) loop
2667                   Prim := Node (Prim_Elmt);
2668
2669                   if not Is_Predefined_Dispatching_Operation (Prim)
2670                     and then Present (Abstract_Interface_Alias (Prim))
2671                     and then not Is_Abstract_Subprogram (Alias (Prim))
2672                     and then not Is_Imported (Alias (Prim))
2673                     and then Find_Dispatching_Type
2674                                (Abstract_Interface_Alias (Prim)) = Iface
2675
2676                      --  Generate the code of the thunk only if the abstract
2677                      --  interface type is not an immediate ancestor of
2678                      --  Tagged_Type; otherwise the DT associated with the
2679                      --  interface is the primary DT.
2680
2681                     and then not Is_Parent (Iface, Typ)
2682                   then
2683                      Expand_Interface_Thunk
2684                        (N           => Prim,
2685                         Thunk_Alias => Alias (Prim),
2686                         Thunk_Id    => Thunk_Id,
2687                         Thunk_Code  => Thunk_Code);
2688
2689                      if Present (Thunk_Id) then
2690                         Pos :=
2691                           UI_To_Int
2692                             (DT_Position (Abstract_Interface_Alias (Prim)));
2693
2694                         Prim_Table (Pos) := Thunk_Id;
2695                         Append_To (Result, Thunk_Code);
2696                      end if;
2697                   end if;
2698
2699                   Next_Elmt (Prim_Elmt);
2700                end loop;
2701
2702                for J in Prim_Table'Range loop
2703                   if Present (Prim_Table (J)) then
2704                      New_Node :=
2705                        Make_Attribute_Reference (Loc,
2706                          Prefix => New_Reference_To (Prim_Table (J), Loc),
2707                          Attribute_Name => Name_Address);
2708                   else
2709                      New_Node :=
2710                        New_Reference_To (RTE (RE_Null_Address), Loc);
2711                   end if;
2712
2713                   Append_To (Prim_Ops_Aggr_List, New_Node);
2714                end loop;
2715             end;
2716          end if;
2717
2718          Append_To (DT_Aggr_List,
2719            Make_Aggregate (Loc,
2720              Expressions => Prim_Ops_Aggr_List));
2721
2722          Append_To (Result,
2723            Make_Object_Declaration (Loc,
2724              Defining_Identifier => Iface_DT,
2725              Aliased_Present     => True,
2726              Object_Definition   =>
2727                Make_Subtype_Indication (Loc,
2728                  Subtype_Mark => New_Reference_To
2729                                    (RTE (RE_Dispatch_Table_Wrapper), Loc),
2730                  Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
2731                                    Constraints => DT_Constr_List)),
2732
2733              Expression => Make_Aggregate (Loc,
2734                Expressions => DT_Aggr_List)));
2735
2736          --  Generate code to create the pointer to the dispatch table
2737
2738          --    Iface_DT_Ptr : Tag := Tag!(DT'Address);
2739
2740          Append_To (Result,
2741            Make_Object_Declaration (Loc,
2742              Defining_Identifier => Iface_DT_Ptr,
2743              Constant_Present    => True,
2744              Object_Definition =>
2745                New_Reference_To (RTE (RE_Interface_Tag), Loc),
2746              Expression =>
2747                Unchecked_Convert_To (Generalized_Tag,
2748                  Make_Attribute_Reference (Loc,
2749                    Prefix =>
2750                      Make_Selected_Component (Loc,
2751                        Prefix => New_Reference_To (Iface_DT, Loc),
2752                      Selector_Name =>
2753                        New_Occurrence_Of
2754                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
2755                    Attribute_Name => Name_Address))));
2756
2757       end Make_Secondary_DT;
2758
2759       --  Local variables
2760
2761       --  Seems a huge list, shouldn't some of these be commented???
2762       --  Seems like we are counting too much on guessing from names here???
2763
2764       Elab_Code          : constant List_Id   := New_List;
2765       Generalized_Tag    : constant Entity_Id := RTE (RE_Tag);
2766       Result             : constant List_Id := New_List;
2767       Tname              : constant Name_Id := Chars (Typ);
2768       Name_DT            : constant Name_Id := New_External_Name (Tname, 'T');
2769       Name_Exname        : constant Name_Id := New_External_Name (Tname, 'E');
2770       Name_Predef_Prims  : constant Name_Id := New_External_Name (Tname, 'R');
2771       Name_SSD           : constant Name_Id := New_External_Name (Tname, 'S');
2772       Name_TSD           : constant Name_Id := New_External_Name (Tname, 'B');
2773       DT                 : constant Entity_Id :=
2774                              Make_Defining_Identifier (Loc, Name_DT);
2775       Exname             : constant Entity_Id :=
2776                              Make_Defining_Identifier (Loc, Name_Exname);
2777       Predef_Prims       : constant Entity_Id :=
2778                              Make_Defining_Identifier (Loc, Name_Predef_Prims);
2779       SSD                : constant Entity_Id :=
2780                              Make_Defining_Identifier (Loc, Name_SSD);
2781       TSD                : constant Entity_Id :=
2782                              Make_Defining_Identifier (Loc, Name_TSD);
2783       AI                 : Elmt_Id;
2784       AI_Tag_Comp        : Elmt_Id;
2785       AI_Ptr_Elmt        : Elmt_Id;
2786       DT_Constr_List     : List_Id;
2787       DT_Aggr_List       : List_Id;
2788       DT_Ptr             : Entity_Id;
2789       Has_Dispatch_Table : Boolean := True;
2790       ITable             : Node_Id;
2791       I_Depth            : Nat := 0;
2792       Iface_Table_Node   : Node_Id;
2793       Name_ITable        : Name_Id;
2794       Name_No_Reg        : Name_Id;
2795       Nb_Predef_Prims    : Nat := 0;
2796       Nb_Prim            : Nat := 0;
2797       New_Node           : Node_Id;
2798       No_Reg             : Node_Id;
2799       Null_Parent_Tag    : Boolean := False;
2800       Num_Ifaces         : Nat := 0;
2801       Old_Tag1           : Node_Id;
2802       Old_Tag2           : Node_Id;
2803       Prim               : Entity_Id;
2804       Prim_Elmt          : Elmt_Id;
2805       Prim_Ops_Aggr_List : List_Id;
2806       Transportable      : Entity_Id;
2807       RC_Offset_Node     : Node_Id;
2808       Suffix_Index       : Int;
2809       Typ_Comps          : Elist_Id;
2810       Typ_Ifaces         : Elist_Id;
2811       TSD_Aggr_List      : List_Id;
2812       TSD_Tags_List      : List_Id;
2813       TSD_Ifaces_List    : List_Id;
2814
2815    --  Start of processing for Make_DT
2816
2817    begin
2818       --  Fill the contents of Access_Disp_Table
2819
2820       --  1) Generate the primary and secondary tag entities
2821
2822       declare
2823          DT_Ptr       : Node_Id;
2824          Name_DT_Ptr  : Name_Id;
2825          Typ_Name     : Name_Id;
2826          Iface_DT_Ptr : Node_Id;
2827          Suffix_Index : Int;
2828          AI_Tag_Comp  : Elmt_Id;
2829
2830       begin
2831          --  Collect the components associated with secondary dispatch tables
2832
2833          if Has_Abstract_Interfaces (Typ) then
2834             Collect_Interface_Components (Typ, Typ_Comps);
2835          end if;
2836
2837          --  Generate the primary tag entity
2838
2839          Name_DT_Ptr := New_External_Name (Tname, 'P');
2840          DT_Ptr      := Make_Defining_Identifier (Loc, Name_DT_Ptr);
2841          Set_Ekind (DT_Ptr, E_Constant);
2842          Set_Is_Statically_Allocated (DT_Ptr);
2843          Set_Is_True_Constant (DT_Ptr);
2844
2845          pragma Assert (No (Access_Disp_Table (Typ)));
2846          Set_Access_Disp_Table (Typ, New_Elmt_List);
2847          Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
2848
2849          --  Generate the secondary tag entities
2850
2851          if Has_Abstract_Interfaces (Typ) then
2852             Suffix_Index := 0;
2853
2854             --  For each interface type we build an unique external name
2855             --  associated with its corresponding secondary dispatch table.
2856             --  This external name will be used to declare an object that
2857             --  references this secondary dispatch table, value that will be
2858             --  used for the elaboration of Typ's objects and also for the
2859             --  elaboration of objects of derivations of Typ that do not
2860             --  override the primitive operation of this interface type.
2861
2862             AI_Tag_Comp := First_Elmt (Typ_Comps);
2863             while Present (AI_Tag_Comp) loop
2864                Get_Secondary_DT_External_Name
2865                  (Typ, Related_Interface (Node (AI_Tag_Comp)), Suffix_Index);
2866
2867                Typ_Name     := Name_Find;
2868                Name_DT_Ptr  := New_External_Name (Typ_Name, "P");
2869                Iface_DT_Ptr := Make_Defining_Identifier (Loc, Name_DT_Ptr);
2870
2871                Set_Ekind (Iface_DT_Ptr, E_Constant);
2872                Set_Is_Statically_Allocated (Iface_DT_Ptr);
2873                Set_Is_True_Constant (Iface_DT_Ptr);
2874                Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
2875
2876                Next_Elmt (AI_Tag_Comp);
2877             end loop;
2878          end if;
2879       end;
2880
2881       --  2) At the end of Access_Disp_Table we add the entity of an access
2882       --     type declaration. It is used by Build_Get_Prim_Op_Address to
2883       --     expand dispatching calls through the primary dispatch table.
2884
2885       --     Generate:
2886       --       type Typ_DT is array (1 .. Nb_Prims) of Address;
2887       --       type Typ_DT_Acc is access Typ_DT;
2888
2889       declare
2890          Name_DT_Prims     : constant Name_Id :=
2891                                New_External_Name (Tname, 'G');
2892          Name_DT_Prims_Acc : constant Name_Id :=
2893                                New_External_Name (Tname, 'H');
2894          DT_Prims          : constant Entity_Id :=
2895                                Make_Defining_Identifier (Loc, Name_DT_Prims);
2896          DT_Prims_Acc      : constant Entity_Id :=
2897                                Make_Defining_Identifier (Loc,
2898                                  Name_DT_Prims_Acc);
2899       begin
2900          Append_To (Result,
2901            Make_Full_Type_Declaration (Loc,
2902              Defining_Identifier => DT_Prims,
2903              Type_Definition =>
2904                Make_Constrained_Array_Definition (Loc,
2905                  Discrete_Subtype_Definitions => New_List (
2906                    Make_Range (Loc,
2907                      Low_Bound  => Make_Integer_Literal (Loc, 1),
2908                      High_Bound => Make_Integer_Literal (Loc,
2909                                     DT_Entry_Count
2910                                       (First_Tag_Component (Typ))))),
2911                  Component_Definition =>
2912                    Make_Component_Definition (Loc,
2913                      Subtype_Indication =>
2914                        New_Reference_To (RTE (RE_Address), Loc)))));
2915
2916          Append_To (Result,
2917            Make_Full_Type_Declaration (Loc,
2918              Defining_Identifier => DT_Prims_Acc,
2919              Type_Definition =>
2920                 Make_Access_To_Object_Definition (Loc,
2921                   Subtype_Indication =>
2922                     New_Occurrence_Of (DT_Prims, Loc))));
2923
2924          Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
2925       end;
2926
2927       if Is_CPP_Class (Typ) then
2928          return Result;
2929       end if;
2930
2931       if No_Run_Time_Mode or else not RTE_Available (RE_Tag) then
2932          DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2933
2934          Append_To (Result,
2935            Make_Object_Declaration (Loc,
2936              Defining_Identifier => DT_Ptr,
2937              Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
2938              Constant_Present    => True,
2939              Expression =>
2940                Unchecked_Convert_To (Generalized_Tag,
2941                  New_Reference_To (RTE (RE_Null_Address), Loc))));
2942
2943          Analyze_List (Result, Suppress => All_Checks);
2944          Error_Msg_CRT ("tagged types", Typ);
2945          return Result;
2946       end if;
2947
2948       if not Static_Dispatch_Tables
2949         or else Is_Local_DT
2950       then
2951          Set_Ekind (DT, E_Variable);
2952          Set_Is_Statically_Allocated (DT);
2953       else
2954          Set_Ekind (DT, E_Constant);
2955          Set_Is_Statically_Allocated (DT);
2956          Set_Is_True_Constant (DT);
2957       end if;
2958
2959       pragma Assert (Present (Access_Disp_Table (Typ)));
2960       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
2961
2962       --  Ada 2005 (AI-251): Build the secondary dispatch tables
2963
2964       if Has_Abstract_Interfaces (Typ) then
2965          Suffix_Index := 0;
2966          AI_Ptr_Elmt  := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
2967
2968          AI_Tag_Comp := First_Elmt (Typ_Comps);
2969          while Present (AI_Tag_Comp) loop
2970             Make_Secondary_DT
2971               (Typ          => Typ,
2972                Iface        => Base_Type
2973                                  (Related_Interface (Node (AI_Tag_Comp))),
2974                AI_Tag       => Node (AI_Tag_Comp),
2975                Iface_DT_Ptr => Node (AI_Ptr_Elmt),
2976                Result       => Result);
2977
2978             Suffix_Index := Suffix_Index + 1;
2979             Next_Elmt (AI_Ptr_Elmt);
2980             Next_Elmt (AI_Tag_Comp);
2981          end loop;
2982       end if;
2983
2984       --  Evaluate if we generate the dispatch table
2985
2986       Has_Dispatch_Table :=
2987         not Is_Interface (Typ)
2988           and then not Restriction_Active (No_Dispatching_Calls);
2989
2990       --  Calculate the number of primitives of the dispatch table and the
2991       --  size of the Type_Specific_Data record.
2992
2993       if Has_Dispatch_Table then
2994          Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
2995       end if;
2996
2997       if not Static_Dispatch_Tables then
2998          Set_Ekind (Predef_Prims, E_Variable);
2999          Set_Is_Statically_Allocated (Predef_Prims);
3000       else
3001          Set_Ekind (Predef_Prims, E_Constant);
3002          Set_Is_Statically_Allocated (Predef_Prims);
3003          Set_Is_True_Constant (Predef_Prims);
3004       end if;
3005
3006       Set_Ekind (SSD, E_Constant);
3007       Set_Is_Statically_Allocated (SSD);
3008       Set_Is_True_Constant (SSD);
3009
3010       Set_Ekind (TSD, E_Constant);
3011       Set_Is_Statically_Allocated (TSD);
3012       Set_Is_True_Constant (TSD);
3013
3014       Set_Ekind (Exname, E_Constant);
3015       Set_Is_Statically_Allocated (Exname);
3016       Set_Is_True_Constant (Exname);
3017
3018       --  Generate code to define the boolean that controls registration, in
3019       --  order to avoid multiple registrations for tagged types defined in
3020       --  multiple-called scopes.
3021
3022       if not Is_Interface (Typ) then
3023          Name_No_Reg := New_External_Name (Tname, 'F');
3024          No_Reg      := Make_Defining_Identifier (Loc, Name_No_Reg);
3025
3026          Set_Ekind (No_Reg, E_Variable);
3027          Set_Is_Statically_Allocated (No_Reg);
3028
3029          Append_To (Result,
3030            Make_Object_Declaration (Loc,
3031              Defining_Identifier => No_Reg,
3032              Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
3033              Expression          => New_Reference_To (Standard_True, Loc)));
3034       end if;
3035
3036       --  In case of locally defined tagged type we declare the object
3037       --  contanining the dispatch table by means of a variable. Its
3038       --  initialization is done later by means of an assignment. This is
3039       --  required to generate its External_Tag.
3040
3041       if Is_Local_DT then
3042
3043          --  Generate:
3044          --    DT     : No_Dispatch_Table_Wrapper;
3045          --    DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
3046
3047          if not Has_Dispatch_Table then
3048             Append_To (Result,
3049               Make_Object_Declaration (Loc,
3050                 Defining_Identifier => DT,
3051                 Aliased_Present     => True,
3052                 Constant_Present    => False,
3053                 Object_Definition   =>
3054                   New_Reference_To
3055                     (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
3056
3057             Append_To (Result,
3058               Make_Object_Declaration (Loc,
3059                 Defining_Identifier => DT_Ptr,
3060                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
3061                 Constant_Present    => True,
3062                 Expression =>
3063                   Unchecked_Convert_To (Generalized_Tag,
3064                     Make_Attribute_Reference (Loc,
3065                       Prefix =>
3066                         Make_Selected_Component (Loc,
3067                           Prefix => New_Reference_To (DT, Loc),
3068                         Selector_Name =>
3069                           New_Occurrence_Of
3070                             (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
3071                       Attribute_Name => Name_Address))));
3072
3073          --  Generate:
3074          --    DT : Dispatch_Table_Wrapper (Nb_Prim);
3075          --    for DT'Alignment use Address'Alignment;
3076          --    DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
3077
3078          else
3079             --  If the tagged type has no primitives we add a dummy slot
3080             --  whose address will be the tag of this type.
3081
3082             if Nb_Prim = 0 then
3083                DT_Constr_List :=
3084                  New_List (Make_Integer_Literal (Loc, 1));
3085             else
3086                DT_Constr_List :=
3087                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
3088             end if;
3089
3090             Append_To (Result,
3091               Make_Object_Declaration (Loc,
3092                 Defining_Identifier => DT,
3093                 Aliased_Present     => True,
3094                 Constant_Present    => False,
3095                 Object_Definition   =>
3096                   Make_Subtype_Indication (Loc,
3097                     Subtype_Mark =>
3098                       New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
3099                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
3100                                     Constraints => DT_Constr_List))));
3101
3102             Append_To (Result,
3103               Make_Attribute_Definition_Clause (Loc,
3104                 Name       => New_Reference_To (DT, Loc),
3105                 Chars      => Name_Alignment,
3106                 Expression =>
3107                   Make_Attribute_Reference (Loc,
3108                     Prefix =>
3109                       New_Reference_To (RTE (RE_Integer_Address), Loc),
3110                     Attribute_Name => Name_Alignment)));
3111
3112             Append_To (Result,
3113               Make_Object_Declaration (Loc,
3114                 Defining_Identifier => DT_Ptr,
3115                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
3116                 Constant_Present    => True,
3117                 Expression =>
3118                   Unchecked_Convert_To (Generalized_Tag,
3119                     Make_Attribute_Reference (Loc,
3120                       Prefix =>
3121                         Make_Selected_Component (Loc,
3122                           Prefix => New_Reference_To (DT, Loc),
3123                         Selector_Name =>
3124                           New_Occurrence_Of
3125                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
3126                       Attribute_Name => Name_Address))));
3127          end if;
3128       end if;
3129
3130       --  Generate: Exname : constant String := full_qualified_name (typ);
3131       --  The type itself may be an anonymous parent type, so use the first
3132       --  subtype to have a user-recognizable name.
3133
3134       Append_To (Result,
3135         Make_Object_Declaration (Loc,
3136           Defining_Identifier => Exname,
3137           Constant_Present    => True,
3138           Object_Definition   => New_Reference_To (Standard_String, Loc),
3139           Expression =>
3140             Make_String_Literal (Loc,
3141               Full_Qualified_Name (First_Subtype (Typ)))));
3142
3143       --  Generate code to create the storage for the type specific data object
3144       --  with enough space to store the tags of the ancestors plus the tags
3145       --  of all the implemented interfaces (as described in a-tags.adb).
3146
3147       --   TSD : Type_Specific_Data (I_Depth) :=
3148       --           (Idepth             => I_Depth,
3149       --            Access_Level       => Type_Access_Level (Typ),
3150       --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
3151       --            External_Tag       => Cstring_Ptr!(Exname'Address))
3152       --            HT_Link            => null,
3153       --            Transportable      => <<boolean-value>>,
3154       --            RC_Offset          => <<integer-value>>,
3155       --            [ Interfaces_Table  => <<access-value>> ]
3156       --            [  SSD              => SSD_Table'Address ]
3157       --            Tags_Table         => (0 => null,
3158       --                                   1 => Parent'Tag
3159       --                                   ...);
3160       --   for TSD'Alignment use Address'Alignment
3161
3162       TSD_Aggr_List := New_List;
3163
3164       --  Idepth: Count ancestors to compute the inheritance depth. For private
3165       --  extensions, always go to the full view in order to compute the real
3166       --  inheritance depth.
3167
3168       declare
3169          Current_Typ : Entity_Id;
3170          Parent_Typ  : Entity_Id;
3171
3172       begin
3173          I_Depth     := 0;
3174          Current_Typ := Typ;
3175          loop
3176             Parent_Typ := Etype (Current_Typ);
3177
3178             if Is_Private_Type (Parent_Typ) then
3179                Parent_Typ := Full_View (Base_Type (Parent_Typ));
3180             end if;
3181
3182             exit when Parent_Typ = Current_Typ;
3183
3184             I_Depth := I_Depth + 1;
3185             Current_Typ := Parent_Typ;
3186          end loop;
3187       end;
3188
3189       Append_To (TSD_Aggr_List,
3190         Make_Component_Association (Loc,
3191           Choices => New_List (
3192             New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)),
3193           Expression =>
3194             Make_Integer_Literal (Loc, I_Depth)));
3195
3196       --  Access_Level
3197
3198       Append_To (TSD_Aggr_List,
3199         Make_Component_Association (Loc,
3200           Choices => New_List (
3201             New_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)),
3202           Expression =>
3203             Make_Integer_Literal (Loc, Type_Access_Level (Typ))));
3204
3205       --  Expanded_Name
3206
3207       Append_To (TSD_Aggr_List,
3208         Make_Component_Association (Loc,
3209           Choices => New_List (
3210             New_Occurrence_Of (RTE_Record_Component (RE_Expanded_Name), Loc)),
3211           Expression =>
3212             Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
3213               Make_Attribute_Reference (Loc,
3214                 Prefix => New_Reference_To (Exname, Loc),
3215                 Attribute_Name => Name_Address))));
3216
3217       --  External_Tag of a local tagged type
3218
3219       --     Exname : constant String :=
3220       --                "Internal tag at 16#tag-addr#: <full-name-of-typ>";
3221
3222       --  The reason we generate this strange name is that we do not want to
3223       --  enter local tagged types in the global hash table used to compute
3224       --  the Internal_Tag attribute for two reasons:
3225
3226       --    1. It is hard to avoid a tasking race condition for entering the
3227       --    entry into the hash table.
3228
3229       --    2. It would cause a storage leak, unless we rig up considerable
3230       --    mechanism to remove the entry from the hash table on exit.
3231
3232       --  So what we do is to generate the above external tag name, where the
3233       --  hex address is the address of the local dispatch table (i.e. exactly
3234       --  the value we want if Internal_Tag is computed from this string).
3235
3236       --  Of course this value will only be valid if the tagged type is still
3237       --  in scope, but it clearly must be erroneous to compute the internal
3238       --  tag of a tagged type that is out of scope!
3239
3240       if Is_Local_DT then
3241          declare
3242             Name_Exname : constant Name_Id := New_External_Name (Tname, 'L');
3243             Name_Str1   : constant Name_Id := New_Internal_Name ('I');
3244             Name_Str2   : constant Name_Id := New_Internal_Name ('I');
3245             Name_Str3   : constant Name_Id := New_Internal_Name ('I');
3246             Exname      : constant Entity_Id :=
3247                             Make_Defining_Identifier (Loc, Name_Exname);
3248             Str1        : constant Entity_Id :=
3249                             Make_Defining_Identifier (Loc, Name_Str1);
3250             Str2        : constant Entity_Id :=
3251                             Make_Defining_Identifier (Loc, Name_Str2);
3252             Str3        : constant Entity_Id :=
3253                             Make_Defining_Identifier (Loc, Name_Str3);
3254             Full_Name   : constant String_Id :=
3255                             Full_Qualified_Name (First_Subtype (Typ));
3256             Str1_Id     : String_Id;
3257             Str2_Id     : String_Id;
3258             Str3_Id     : String_Id;
3259
3260          begin
3261             --  Generate:
3262             --    Str1 : constant String := "Internal tag at 16#";
3263
3264             Set_Ekind (Str1, E_Constant);
3265             Set_Is_Statically_Allocated (Str1);
3266             Set_Is_True_Constant (Str1);
3267
3268             Start_String;
3269             Store_String_Chars ("Internal tag at 16#");
3270             Str1_Id := End_String;
3271
3272             --  Generate:
3273             --    Str2 : constant String := "#: ";
3274
3275             Set_Ekind (Str2, E_Constant);
3276             Set_Is_Statically_Allocated (Str2);
3277             Set_Is_True_Constant (Str2);
3278
3279             Start_String;
3280             Store_String_Chars ("#: ");
3281             Str2_Id := End_String;
3282
3283             --  Generate:
3284             --    Str3 : constant String := <full-name-of-typ>;
3285
3286             Set_Ekind (Str3, E_Constant);
3287             Set_Is_Statically_Allocated (Str3);
3288             Set_Is_True_Constant (Str3);
3289
3290             Start_String;
3291             Store_String_Chars (Full_Name);
3292             Str3_Id := End_String;
3293
3294             --  Generate:
3295             --    Exname : constant String :=
3296             --               Str1 & Address_Image (Tag) & Str2 & Str3;
3297
3298             if RTE_Available (RE_Address_Image) then
3299                Append_To (Result,
3300                  Make_Object_Declaration (Loc,
3301                    Defining_Identifier => Exname,
3302                    Constant_Present    => True,
3303                    Object_Definition   => New_Reference_To
3304                                             (Standard_String, Loc),
3305                    Expression =>
3306                      Make_Op_Concat (Loc,
3307                        Left_Opnd =>
3308                          Make_String_Literal (Loc, Str1_Id),
3309                        Right_Opnd =>
3310                          Make_Op_Concat (Loc,
3311                            Left_Opnd =>
3312                              Make_Function_Call (Loc,
3313                                Name =>
3314                                  New_Reference_To
3315                                    (RTE (RE_Address_Image), Loc),
3316                                Parameter_Associations => New_List (
3317                                  Unchecked_Convert_To (RTE (RE_Address),
3318                                    New_Reference_To (DT_Ptr, Loc)))),
3319                            Right_Opnd =>
3320                              Make_Op_Concat (Loc,
3321                                Left_Opnd =>
3322                                  Make_String_Literal (Loc, Str2_Id),
3323                                Right_Opnd =>
3324                                  Make_String_Literal (Loc, Str3_Id))))));
3325             else
3326                Append_To (Result,
3327                  Make_Object_Declaration (Loc,
3328                    Defining_Identifier => Exname,
3329                    Constant_Present    => True,
3330                    Object_Definition   => New_Reference_To
3331                                             (Standard_String, Loc),
3332                    Expression =>
3333                      Make_Op_Concat (Loc,
3334                        Left_Opnd =>
3335                          Make_String_Literal (Loc, Str1_Id),
3336                        Right_Opnd =>
3337                          Make_Op_Concat (Loc,
3338                            Left_Opnd =>
3339                              Make_String_Literal (Loc, Str2_Id),
3340                            Right_Opnd =>
3341                              Make_String_Literal (Loc, Str3_Id)))));
3342             end if;
3343
3344             New_Node :=
3345               Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
3346                 Make_Attribute_Reference (Loc,
3347                   Prefix => New_Reference_To (Exname, Loc),
3348                   Attribute_Name => Name_Address));
3349          end;
3350
3351       --  External tag of a library-level tagged type: Check for a definition
3352       --  of External_Tag. The clause is considered only if it applies to this
3353       --  specific tagged type, as opposed to one of its ancestors.
3354
3355       else
3356          declare
3357             Def : constant Node_Id := Get_Attribute_Definition_Clause (Typ,
3358                                         Attribute_External_Tag);
3359             Old_Val : String_Id;
3360             New_Val : String_Id;
3361             E       : Entity_Id;
3362
3363          begin
3364             if not Present (Def)
3365               or else Entity (Name (Def)) /= Typ
3366             then
3367                New_Node :=
3368                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
3369                    Make_Attribute_Reference (Loc,
3370                      Prefix => New_Reference_To (Exname, Loc),
3371                      Attribute_Name => Name_Address));
3372             else
3373                Old_Val := Strval (Expr_Value_S (Expression (Def)));
3374
3375                --  For the rep clause "for x'external_tag use y" generate:
3376
3377                --     xV : constant string := y;
3378                --     Set_External_Tag (x'tag, xV'Address);
3379                --     Register_Tag (x'tag);
3380
3381                --  Create a new nul terminated string if it is not already
3382
3383                if String_Length (Old_Val) > 0
3384                  and then
3385                   Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
3386                then
3387                   New_Val := Old_Val;
3388                else
3389                   Start_String (Old_Val);
3390                   Store_String_Char (Get_Char_Code (ASCII.NUL));
3391                   New_Val := End_String;
3392                end if;
3393
3394                E := Make_Defining_Identifier (Loc,
3395                       New_External_Name (Chars (Typ), 'A'));
3396
3397                Append_To (Result,
3398                  Make_Object_Declaration (Loc,
3399                    Defining_Identifier => E,
3400                    Constant_Present    => True,
3401                    Object_Definition   =>
3402                      New_Reference_To (Standard_String, Loc),
3403                    Expression          =>
3404                      Make_String_Literal (Loc, New_Val)));
3405
3406                New_Node :=
3407                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
3408                    Make_Attribute_Reference (Loc,
3409                      Prefix => New_Reference_To (E, Loc),
3410                      Attribute_Name => Name_Address));
3411             end if;
3412          end;
3413       end if;
3414
3415       Append_To (TSD_Aggr_List,
3416         Make_Component_Association (Loc,
3417           Choices => New_List (
3418             New_Occurrence_Of
3419               (RTE_Record_Component (RE_External_Tag), Loc)),
3420           Expression => New_Node));
3421
3422       --  HT_Link
3423
3424       Append_To (TSD_Aggr_List,
3425         Make_Component_Association (Loc,
3426           Choices => New_List (
3427             New_Occurrence_Of
3428               (RTE_Record_Component (RE_HT_Link), Loc)),
3429           Expression =>
3430             Unchecked_Convert_To (RTE (RE_Tag),
3431               New_Reference_To (RTE (RE_Null_Address), Loc))));
3432
3433       --  Transportable: Set for types that can be used in remote calls
3434       --  with respect to E.4(18) legality rules.
3435
3436       Transportable :=
3437         Boolean_Literals
3438           (Is_Pure (Typ)
3439              or else Is_Shared_Passive (Typ)
3440              or else
3441                ((Is_Remote_Types (Typ)
3442                    or else Is_Remote_Call_Interface (Typ))
3443                 and then Original_View_In_Visible_Part (Typ))
3444              or else not Comes_From_Source (Typ));
3445
3446       Append_To (TSD_Aggr_List,
3447         Make_Component_Association (Loc,
3448           Choices => New_List (
3449             New_Occurrence_Of
3450              (RTE_Record_Component (RE_Transportable), Loc)),
3451           Expression => New_Occurrence_Of (Transportable, Loc)));
3452
3453       --  RC_Offset: These are the valid values and their meaning:
3454
3455       --   >0: For simple types with controlled components is
3456       --         type._record_controller'position
3457
3458       --    0: For types with no controlled components
3459
3460       --   -1: For complex types with controlled components where the position
3461       --       of the record controller is not statically computable but there
3462       --       are controlled components at this level. The _Controller field
3463       --       is available right after the _parent.
3464
3465       --   -2: There are no controlled components at this level. We need to
3466       --       get the position from the parent.
3467
3468       if not Has_Controlled_Component (Typ) then
3469          RC_Offset_Node := Make_Integer_Literal (Loc, 0);
3470
3471       elsif Etype (Typ) /= Typ
3472         and then Has_Discriminants (Etype (Typ))
3473       then
3474          if Has_New_Controlled_Component (Typ) then
3475             RC_Offset_Node := Make_Integer_Literal (Loc, -1);
3476          else
3477             RC_Offset_Node := Make_Integer_Literal (Loc, -2);
3478          end if;
3479       else
3480          RC_Offset_Node :=
3481            Make_Attribute_Reference (Loc,
3482              Prefix =>
3483                Make_Selected_Component (Loc,
3484                  Prefix => New_Reference_To (Typ, Loc),
3485                  Selector_Name =>
3486                    New_Reference_To (Controller_Component (Typ), Loc)),
3487              Attribute_Name => Name_Position);
3488
3489          --  This is not proper Ada code to use the attribute 'Position
3490          --  on something else than an object but this is supported by
3491          --  the back end (see comment on the Bit_Component attribute in
3492          --  sem_attr). So we avoid semantic checking here.
3493
3494          --  Is this documented in sinfo.ads??? it should be!
3495
3496          Set_Analyzed (RC_Offset_Node);
3497          Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
3498          Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
3499          Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
3500            RTE (RE_Record_Controller));
3501          Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
3502       end if;
3503
3504       Append_To (TSD_Aggr_List,
3505         Make_Component_Association (Loc,
3506           Choices => New_List (
3507             New_Occurrence_Of (RTE_Record_Component (RE_RC_Offset), Loc)),
3508           Expression => RC_Offset_Node));
3509
3510       --  Interfaces_Table (required for AI-405)
3511
3512       if RTE_Record_Component_Available (RE_Interfaces_Table) then
3513
3514          --  Count the number of interface types implemented by Typ
3515
3516          Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
3517
3518          AI := First_Elmt (Typ_Ifaces);
3519          while Present (AI) loop
3520             Num_Ifaces := Num_Ifaces + 1;
3521             Next_Elmt (AI);
3522          end loop;
3523
3524          if Num_Ifaces = 0 then
3525             Iface_Table_Node := Make_Null (Loc);
3526
3527          --  Generate the Interface_Table object
3528
3529          else
3530             TSD_Ifaces_List := New_List;
3531
3532             declare
3533                Pos       : Nat := 1;
3534                Aggr_List : List_Id;
3535
3536             begin
3537                AI := First_Elmt (Typ_Ifaces);
3538                while Present (AI) loop
3539                   Aggr_List := New_List (
3540                     Make_Component_Association (Loc,
3541                       Choices => New_List (
3542                         New_Occurrence_Of
3543                           (RTE_Record_Component (RE_Iface_Tag), Loc)),
3544                       Expression =>
3545                         Unchecked_Convert_To (Generalized_Tag,
3546                           New_Reference_To
3547                             (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
3548                              Loc))),
3549
3550                     Make_Component_Association (Loc,
3551                       Choices => New_List (
3552                         New_Occurrence_Of
3553                           (RTE_Record_Component (RE_Static_Offset_To_Top),
3554                            Loc)),
3555                       Expression =>
3556                         New_Reference_To (Standard_True, Loc)),
3557
3558                     Make_Component_Association (Loc,
3559                       Choices     => New_List (Make_Others_Choice (Loc)),
3560                       Expression  => Empty,
3561                       Box_Present => True));
3562
3563                   Append_To (TSD_Ifaces_List,
3564                     Make_Component_Association (Loc,
3565                       Choices => New_List (
3566                         Make_Integer_Literal (Loc, Pos)),
3567                       Expression => Make_Aggregate (Loc,
3568                         Component_Associations => Aggr_List)));
3569
3570                   Pos := Pos + 1;
3571                   Next_Elmt (AI);
3572                end loop;
3573             end;
3574
3575             Name_ITable := New_External_Name (Tname, 'I');
3576             ITable      := Make_Defining_Identifier (Loc, Name_ITable);
3577
3578             Set_Ekind (ITable, E_Constant);
3579             Set_Is_Statically_Allocated (ITable);
3580             Set_Is_True_Constant (ITable);
3581
3582             Append_To (Result,
3583               Make_Object_Declaration (Loc,
3584                 Defining_Identifier => ITable,
3585                 Aliased_Present     => True,
3586                 Object_Definition   =>
3587                   Make_Subtype_Indication (Loc,
3588                     Subtype_Mark =>
3589                       New_Reference_To (RTE (RE_Interface_Data), Loc),
3590                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
3591                       Constraints => New_List (
3592                         Make_Integer_Literal (Loc, Num_Ifaces)))),
3593
3594                 Expression => Make_Aggregate (Loc,
3595                   Component_Associations => New_List (
3596                     Make_Component_Association (Loc,
3597                       Choices => New_List (
3598                         New_Occurrence_Of
3599                           (RTE_Record_Component (RE_Nb_Ifaces), Loc)),
3600                       Expression =>
3601                         Make_Integer_Literal (Loc, Num_Ifaces)),
3602
3603                     Make_Component_Association (Loc,
3604                       Choices => New_List (
3605                         New_Occurrence_Of
3606                           (RTE_Record_Component (RE_Ifaces_Table), Loc)),
3607                       Expression => Make_Aggregate (Loc,
3608                         Component_Associations => TSD_Ifaces_List))))));
3609
3610             Iface_Table_Node :=
3611               Make_Attribute_Reference (Loc,
3612                 Prefix         => New_Reference_To (ITable, Loc),
3613                 Attribute_Name => Name_Unchecked_Access);
3614          end if;
3615
3616          Append_To (TSD_Aggr_List,
3617            Make_Component_Association (Loc,
3618              Choices => New_List (
3619                New_Occurrence_Of
3620                 (RTE_Record_Component (RE_Interfaces_Table), Loc)),
3621              Expression => Iface_Table_Node));
3622       end if;
3623
3624       --  Generate the Select Specific Data table for synchronized types that
3625       --  implement synchronized interfaces. The size of the table is
3626       --  constrained by the number of non-predefined primitive operations.
3627
3628       if RTE_Record_Component_Available (RE_SSD) then
3629          if Ada_Version >= Ada_05
3630            and then Has_Dispatch_Table
3631            and then Is_Concurrent_Record_Type (Typ)
3632            and then Has_Abstract_Interfaces (Typ)
3633            and then Nb_Prim > 0
3634            and then not Is_Abstract_Type (Typ)
3635            and then not Is_Controlled (Typ)
3636            and then not Restriction_Active (No_Dispatching_Calls)
3637          then
3638             Append_To (Result,
3639               Make_Object_Declaration (Loc,
3640                 Defining_Identifier => SSD,
3641                 Aliased_Present     => True,
3642                 Object_Definition   =>
3643                   Make_Subtype_Indication (Loc,
3644                     Subtype_Mark => New_Reference_To (
3645                       RTE (RE_Select_Specific_Data), Loc),
3646                     Constraint   =>
3647                       Make_Index_Or_Discriminant_Constraint (Loc,
3648                         Constraints => New_List (
3649                           Make_Integer_Literal (Loc, Nb_Prim))))));
3650
3651             --  This table is initialized by Make_Select_Specific_Data_Table,
3652             --  which calls Set_Entry_Index and Set_Prim_Op_Kind.
3653
3654             Append_To (TSD_Aggr_List,
3655               Make_Component_Association (Loc,
3656                 Choices => New_List (
3657                   New_Occurrence_Of
3658                    (RTE_Record_Component (RE_SSD), Loc)),
3659                 Expression =>
3660                   Make_Attribute_Reference (Loc,
3661                     Prefix => New_Reference_To (SSD, Loc),
3662                     Attribute_Name => Name_Unchecked_Access)));
3663          else
3664             Append_To (TSD_Aggr_List,
3665               Make_Component_Association (Loc,
3666                 Choices => New_List (
3667                   New_Occurrence_Of
3668                    (RTE_Record_Component (RE_SSD), Loc)),
3669                 Expression => Make_Null (Loc)));
3670          end if;
3671       end if;
3672
3673       --  Initialize the table of ancestor tags. In case of interface types
3674       --  this table is not needed.
3675
3676       if Is_Interface (Typ) then
3677          Append_To (TSD_Aggr_List,
3678            Make_Component_Association (Loc,
3679              Choices     => New_List (Make_Others_Choice (Loc)),
3680              Expression  => Empty,
3681              Box_Present => True));
3682       else
3683          declare
3684             Current_Typ : Entity_Id;
3685             Parent_Typ  : Entity_Id;
3686             Pos         : Nat;
3687
3688          begin
3689             TSD_Tags_List := New_List;
3690
3691             --  Fill position 0 with null because we still have not generated
3692             --  the tag of Typ.
3693
3694             Append_To (TSD_Tags_List,
3695               Make_Component_Association (Loc,
3696                 Choices => New_List (
3697                   Make_Integer_Literal (Loc, 0)),
3698                 Expression =>
3699                   Unchecked_Convert_To (RTE (RE_Tag),
3700                     New_Reference_To (RTE (RE_Null_Address), Loc))));
3701
3702             --  Fill the rest of the table with the tags of the ancestors
3703
3704             Pos := 1;
3705             Current_Typ := Typ;
3706
3707             loop
3708                Parent_Typ := Etype (Current_Typ);
3709
3710                if Is_Private_Type (Parent_Typ) then
3711                   Parent_Typ := Full_View (Base_Type (Parent_Typ));
3712                end if;
3713
3714                exit when Parent_Typ = Current_Typ;
3715
3716                if Is_CPP_Class (Parent_Typ) then
3717
3718                   --  The tags defined in the C++ side will be inherited when
3719                   --  the object is constructed.
3720                   --  (see Exp_Ch3.Build_Init_Procedure)
3721
3722                   Append_To (TSD_Tags_List,
3723                     Make_Component_Association (Loc,
3724                       Choices => New_List (
3725                         Make_Integer_Literal (Loc, Pos)),
3726                       Expression =>
3727                         Unchecked_Convert_To (RTE (RE_Tag),
3728                           New_Reference_To (RTE (RE_Null_Address), Loc))));
3729                else
3730                   Append_To (TSD_Tags_List,
3731                     Make_Component_Association (Loc,
3732                       Choices => New_List (
3733                         Make_Integer_Literal (Loc, Pos)),
3734                       Expression =>
3735                         New_Reference_To
3736                          (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
3737                           Loc)));
3738                end if;
3739
3740                Pos := Pos + 1;
3741                Current_Typ := Parent_Typ;
3742             end loop;
3743
3744             pragma Assert (Pos = I_Depth + 1);
3745          end;
3746
3747          Append_To (TSD_Aggr_List,
3748            Make_Component_Association (Loc,
3749              Choices => New_List (
3750                New_Occurrence_Of
3751                  (RTE_Record_Component (RE_Tags_Table), Loc)),
3752              Expression => Make_Aggregate (Loc,
3753                Component_Associations => TSD_Tags_List)));
3754       end if;
3755
3756       --  Build the TSD object
3757
3758       Append_To (Result,
3759         Make_Object_Declaration (Loc,
3760           Defining_Identifier => TSD,
3761           Aliased_Present     => True,
3762           Object_Definition   =>
3763             Make_Subtype_Indication (Loc,
3764               Subtype_Mark => New_Reference_To (
3765                 RTE (RE_Type_Specific_Data), Loc),
3766               Constraint =>
3767                 Make_Index_Or_Discriminant_Constraint (Loc,
3768                   Constraints => New_List (
3769                     Make_Integer_Literal (Loc, I_Depth)))),
3770
3771           Expression => Make_Aggregate (Loc,
3772             Component_Associations => TSD_Aggr_List)));
3773
3774       Append_To (Result,
3775         Make_Attribute_Definition_Clause (Loc,
3776           Name       => New_Reference_To (TSD, Loc),
3777           Chars      => Name_Alignment,
3778           Expression =>
3779             Make_Attribute_Reference (Loc,
3780               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
3781               Attribute_Name => Name_Alignment)));
3782
3783       --  Generate the dummy Dispatch_Table object associated with tagged
3784       --  types that have no dispatch table.
3785
3786       --   DT : No_Dispatch_Table :=
3787       --          (NDT_TSD       => TSD'Address;
3788       --           NDT_Prims_Ptr => 0);
3789
3790       if not Has_Dispatch_Table then
3791          DT_Constr_List := New_List;
3792          DT_Aggr_List   := New_List;
3793
3794          --  Typeinfo
3795
3796          New_Node :=
3797            Make_Attribute_Reference (Loc,
3798              Prefix => New_Reference_To (TSD, Loc),
3799              Attribute_Name => Name_Address);
3800
3801          Append_To (DT_Constr_List, New_Node);
3802          Append_To (DT_Aggr_List,   New_Copy (New_Node));
3803          Append_To (DT_Aggr_List,   Make_Integer_Literal (Loc, 0));
3804
3805          --  In case of locally defined tagged types we have already declared
3806          --  and uninitialized object for the dispatch table, which is now
3807          --  initialized by means of an assignment.
3808
3809          if Is_Local_DT then
3810             Append_To (Result,
3811               Make_Assignment_Statement (Loc,
3812                 Name => New_Reference_To (DT, Loc),
3813                 Expression => Make_Aggregate (Loc,
3814                   Expressions => DT_Aggr_List)));
3815
3816          --  In case of library level tagged types we declare now the constant
3817          --  object containing the dispatch table.
3818
3819          else
3820             Append_To (Result,
3821               Make_Object_Declaration (Loc,
3822                 Defining_Identifier => DT,
3823                 Aliased_Present     => True,
3824                 Constant_Present    => Static_Dispatch_Tables,
3825                 Object_Definition   =>
3826                   New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
3827                 Expression => Make_Aggregate (Loc,
3828                   Expressions => DT_Aggr_List)));
3829
3830             Append_To (Result,
3831               Make_Object_Declaration (Loc,
3832                 Defining_Identifier => DT_Ptr,
3833                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
3834                 Constant_Present    => True,
3835                 Expression =>
3836                   Unchecked_Convert_To (Generalized_Tag,
3837                     Make_Attribute_Reference (Loc,
3838                       Prefix =>
3839                         Make_Selected_Component (Loc,
3840                           Prefix => New_Reference_To (DT, Loc),
3841                         Selector_Name =>
3842                           New_Occurrence_Of
3843                             (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
3844                       Attribute_Name => Name_Address))));
3845          end if;
3846
3847       --  Common case: Typ has a dispatch table
3848
3849       --  Generate:
3850
3851       --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
3852       --                    (predef-prim-op-1'address,
3853       --                     predef-prim-op-2'address,
3854       --                     ...
3855       --                     predef-prim-op-n'address);
3856       --   for Predef_Prims'Alignment use Address'Alignment
3857
3858       --   DT : Dispatch_Table (Nb_Prims) :=
3859       --          (Signature => <sig-value>,
3860       --           Tag_Kind  => <tag_kind-value>,
3861       --           Predef_Prims => Predef_Prims'First'Address,
3862       --           Offset_To_Top => 0,
3863       --           TSD           => TSD'Address;
3864       --           Prims_Ptr     => (prim-op-1'address,
3865       --                             prim-op-2'address,
3866       --                             ...
3867       --                             prim-op-n'address));
3868
3869       else
3870          declare
3871             Pos : Nat;
3872
3873          begin
3874             if not Static_Dispatch_Tables then
3875                Nb_Predef_Prims := Max_Predef_Prims;
3876
3877             else
3878                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3879                while Present (Prim_Elmt) loop
3880                   Prim := Node (Prim_Elmt);
3881
3882                   if Is_Predefined_Dispatching_Operation (Prim)
3883                     and then not Is_Abstract_Subprogram (Prim)
3884                   then
3885                      Pos := UI_To_Int (DT_Position (Prim));
3886
3887                      if Pos > Nb_Predef_Prims then
3888                         Nb_Predef_Prims := Pos;
3889                      end if;
3890                   end if;
3891
3892                   Next_Elmt (Prim_Elmt);
3893                end loop;
3894             end if;
3895
3896             declare
3897                Prim_Table : array
3898                               (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
3899                E          : Entity_Id;
3900
3901             begin
3902                Prim_Ops_Aggr_List := New_List;
3903
3904                Prim_Table := (others => Empty);
3905                Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
3906                while Present (Prim_Elmt) loop
3907                   Prim := Node (Prim_Elmt);
3908
3909                   if Static_Dispatch_Tables
3910                     and then Is_Predefined_Dispatching_Operation (Prim)
3911                     and then not Is_Abstract_Subprogram (Prim)
3912                     and then not Present (Prim_Table
3913                                            (UI_To_Int (DT_Position (Prim))))
3914                   then
3915                      E := Prim;
3916                      while Present (Alias (E)) loop
3917                         E := Alias (E);
3918                      end loop;
3919
3920                      pragma Assert (not Is_Abstract_Subprogram (E));
3921                      Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
3922                   end if;
3923
3924                   Next_Elmt (Prim_Elmt);
3925                end loop;
3926
3927                for J in Prim_Table'Range loop
3928                   if Present (Prim_Table (J)) then
3929                      New_Node :=
3930                        Make_Attribute_Reference (Loc,
3931                          Prefix => New_Reference_To (Prim_Table (J), Loc),
3932                          Attribute_Name => Name_Address);
3933                   else
3934                      New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
3935                   end if;
3936
3937                   Append_To (Prim_Ops_Aggr_List, New_Node);
3938                end loop;
3939
3940                Append_To (Result,
3941                  Make_Object_Declaration (Loc,
3942                    Defining_Identifier => Predef_Prims,
3943                    Aliased_Present     => True,
3944                    Constant_Present    => Static_Dispatch_Tables,
3945                    Object_Definition   =>
3946                      New_Reference_To (RTE (RE_Address_Array), Loc),
3947                    Expression => Make_Aggregate (Loc,
3948                      Expressions => Prim_Ops_Aggr_List)));
3949
3950                Append_To (Result,
3951                  Make_Attribute_Definition_Clause (Loc,
3952                    Name       => New_Reference_To (Predef_Prims, Loc),
3953                    Chars      => Name_Alignment,
3954                    Expression =>
3955                      Make_Attribute_Reference (Loc,
3956                        Prefix =>
3957                          New_Reference_To (RTE (RE_Integer_Address), Loc),
3958                        Attribute_Name => Name_Alignment)));
3959             end;
3960          end;
3961
3962          --  Stage 1: Initialize the discriminant and the record components
3963
3964          DT_Constr_List := New_List;
3965          DT_Aggr_List   := New_List;
3966
3967          --  Num_Prims. If the tagged type has no primitives we add a dummy
3968          --  slot whose address will be the tag of this type.
3969
3970          if Nb_Prim = 0 then
3971             New_Node := Make_Integer_Literal (Loc, 1);
3972          else
3973             New_Node := Make_Integer_Literal (Loc, Nb_Prim);
3974          end if;
3975
3976          Append_To (DT_Constr_List, New_Node);
3977          Append_To (DT_Aggr_List,   New_Copy (New_Node));
3978
3979          --  Signature
3980
3981          if RTE_Record_Component_Available (RE_Signature) then
3982             Append_To (DT_Aggr_List,
3983               New_Reference_To (RTE (RE_Primary_DT), Loc));
3984          end if;
3985
3986          --  Tag_Kind
3987
3988          if RTE_Record_Component_Available (RE_Tag_Kind) then
3989             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
3990          end if;
3991
3992          --  Predef_Prims
3993
3994          Append_To (DT_Aggr_List,
3995            Make_Attribute_Reference (Loc,
3996              Prefix => New_Reference_To (Predef_Prims, Loc),
3997              Attribute_Name => Name_Address));
3998
3999          --  Offset_To_Top
4000
4001          if RTE_Record_Component_Available (RE_Offset_To_Top) then
4002             Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
4003          end if;
4004
4005          --  Typeinfo
4006
4007          Append_To (DT_Aggr_List,
4008            Make_Attribute_Reference (Loc,
4009              Prefix => New_Reference_To (TSD, Loc),
4010              Attribute_Name => Name_Address));
4011
4012          --  Stage 2: Initialize the table of primitive operations
4013
4014          Prim_Ops_Aggr_List := New_List;
4015
4016          if Nb_Prim = 0 then
4017             Append_To (Prim_Ops_Aggr_List,
4018               New_Reference_To (RTE (RE_Null_Address), Loc));
4019
4020          elsif not Static_Dispatch_Tables then
4021             for J in 1 .. Nb_Prim loop
4022                Append_To (Prim_Ops_Aggr_List,
4023                  New_Reference_To (RTE (RE_Null_Address), Loc));
4024             end loop;
4025
4026          else
4027             declare
4028                Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
4029                E          : Entity_Id;
4030                Prim       : Entity_Id;
4031                Prim_Elmt  : Elmt_Id;
4032
4033             begin
4034                Prim_Table := (others => Empty);
4035                Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
4036                while Present (Prim_Elmt) loop
4037                   Prim := Node (Prim_Elmt);
4038
4039                   if Is_Imported (Prim)
4040                     or else Present (Abstract_Interface_Alias (Prim))
4041                     or else Is_Predefined_Dispatching_Operation (Prim)
4042                   then
4043                      null;
4044
4045                   else
4046                      --  Traverse the list of aliased entities to handle
4047                      --  renamings of predefined primitives.
4048
4049                      E := Prim;
4050                      while Present (Alias (E)) loop
4051                         E := Alias (E);
4052                      end loop;
4053
4054                      if not Is_Predefined_Dispatching_Operation (E)
4055                        and then not Is_Abstract_Subprogram (E)
4056                        and then not Present (Abstract_Interface_Alias (E))
4057                      then
4058                         pragma Assert
4059                           (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
4060
4061                         Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
4062
4063                         --  There is no need to set Has_Delayed_Freeze here
4064                         --  because the analysis of 'Address and 'Code_Address
4065                         --  takes care of it.
4066                      end if;
4067                   end if;
4068
4069                   Next_Elmt (Prim_Elmt);
4070                end loop;
4071
4072                for J in Prim_Table'Range loop
4073                   if Present (Prim_Table (J)) then
4074                      New_Node :=
4075                        Make_Attribute_Reference (Loc,
4076                          Prefix => New_Reference_To (Prim_Table (J), Loc),
4077                          Attribute_Name => Name_Address);
4078                   else
4079                      New_Node := New_Reference_To (RTE (RE_Null_Address), Loc);
4080                   end if;
4081
4082                   Append_To (Prim_Ops_Aggr_List, New_Node);
4083                end loop;
4084             end;
4085          end if;
4086
4087          Append_To (DT_Aggr_List,
4088            Make_Aggregate (Loc,
4089              Expressions => Prim_Ops_Aggr_List));
4090
4091          --  In case of locally defined tagged types we have already declared
4092          --  and uninitialized object for the dispatch table, which is now
4093          --  initialized by means of an assignment.
4094
4095          if Is_Local_DT then
4096             Append_To (Result,
4097               Make_Assignment_Statement (Loc,
4098                 Name => New_Reference_To (DT, Loc),
4099                 Expression => Make_Aggregate (Loc,
4100                   Expressions => DT_Aggr_List)));
4101
4102          --  In case of library level tagged types we declare now the constant
4103          --  object containing the dispatch table.
4104
4105          else
4106             Append_To (Result,
4107               Make_Object_Declaration (Loc,
4108                 Defining_Identifier => DT,
4109                 Aliased_Present     => True,
4110                 Constant_Present    => Static_Dispatch_Tables,
4111                 Object_Definition   =>
4112                   Make_Subtype_Indication (Loc,
4113                     Subtype_Mark => New_Reference_To
4114                                       (RTE (RE_Dispatch_Table_Wrapper), Loc),
4115                     Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
4116                                       Constraints => DT_Constr_List)),
4117                 Expression => Make_Aggregate (Loc,
4118                   Expressions => DT_Aggr_List)));
4119
4120             Append_To (Result,
4121               Make_Attribute_Definition_Clause (Loc,
4122                 Name       => New_Reference_To (DT, Loc),
4123                 Chars      => Name_Alignment,
4124                 Expression =>
4125                   Make_Attribute_Reference (Loc,
4126                     Prefix =>
4127                       New_Reference_To (RTE (RE_Integer_Address), Loc),
4128                     Attribute_Name => Name_Alignment)));
4129
4130             Append_To (Result,
4131               Make_Object_Declaration (Loc,
4132                 Defining_Identifier => DT_Ptr,
4133                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
4134                 Constant_Present    => True,
4135                 Expression =>
4136                   Unchecked_Convert_To (Generalized_Tag,
4137                     Make_Attribute_Reference (Loc,
4138                       Prefix =>
4139                         Make_Selected_Component (Loc,
4140                           Prefix => New_Reference_To (DT, Loc),
4141                         Selector_Name =>
4142                           New_Occurrence_Of
4143                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4144                       Attribute_Name => Name_Address))));
4145          end if;
4146       end if;
4147
4148       --  Initialize the table of ancestor tags
4149
4150       if not Is_Interface (Typ)
4151         and then not Is_CPP_Class (Typ)
4152       then
4153          Append_To (Result,
4154            Make_Assignment_Statement (Loc,
4155              Name =>
4156                Make_Indexed_Component (Loc,
4157                  Prefix =>
4158                    Make_Selected_Component (Loc,
4159                      Prefix =>
4160                        New_Reference_To (TSD, Loc),
4161                      Selector_Name =>
4162                        New_Reference_To
4163                          (RTE_Record_Component (RE_Tags_Table), Loc)),
4164                  Expressions =>
4165                     New_List (Make_Integer_Literal (Loc, 0))),
4166
4167              Expression =>
4168                New_Reference_To
4169                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
4170       end if;
4171
4172       if Static_Dispatch_Tables then
4173          null;
4174
4175       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
4176       --  in the init proc, and we don't need to fill them in here.
4177
4178       elsif Is_CPP_Class (Etype (Typ)) then
4179          null;
4180
4181          --  Otherwise we fill in the dispatch tables here
4182
4183       else
4184          if Typ = Etype (Typ)
4185            or else Is_CPP_Class (Etype (Typ))
4186            or else Is_Interface (Typ)
4187          then
4188             Null_Parent_Tag := True;
4189
4190             Old_Tag1 :=
4191               Unchecked_Convert_To (Generalized_Tag,
4192                 Make_Integer_Literal (Loc, 0));
4193             Old_Tag2 :=
4194               Unchecked_Convert_To (Generalized_Tag,
4195                 Make_Integer_Literal (Loc, 0));
4196
4197          else
4198             Old_Tag1 :=
4199               New_Reference_To
4200                 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
4201             Old_Tag2 :=
4202               New_Reference_To
4203                 (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
4204          end if;
4205
4206          if Typ /= Etype (Typ)
4207            and then not Is_Interface (Typ)
4208            and then not Restriction_Active (No_Dispatching_Calls)
4209          then
4210             --  Inherit the dispatch table
4211
4212             if not Is_Interface (Etype (Typ)) then
4213                if not Null_Parent_Tag then
4214                   declare
4215                      Nb_Prims : constant Int :=
4216                                   UI_To_Int (DT_Entry_Count
4217                                     (First_Tag_Component (Etype (Typ))));
4218                   begin
4219                      Append_To (Elab_Code,
4220                        Build_Inherit_Predefined_Prims (Loc,
4221                          Old_Tag_Node => Old_Tag1,
4222                          New_Tag_Node =>
4223                            New_Reference_To (DT_Ptr, Loc)));
4224
4225                      if Nb_Prims /= 0 then
4226                         Append_To (Elab_Code,
4227                           Build_Inherit_Prims (Loc,
4228                             Old_Tag_Node => Old_Tag2,
4229                             New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
4230                             Num_Prims    => Nb_Prims));
4231                      end if;
4232                   end;
4233                end if;
4234             end if;
4235
4236             --  Inherit the secondary dispatch tables of the ancestor
4237
4238             if not Is_CPP_Class (Etype (Typ)) then
4239                declare
4240                   Sec_DT_Ancestor : Elmt_Id :=
4241                                       Next_Elmt
4242                                         (First_Elmt
4243                                            (Access_Disp_Table (Etype (Typ))));
4244                   Sec_DT_Typ      : Elmt_Id :=
4245                                       Next_Elmt
4246                                         (First_Elmt
4247                                            (Access_Disp_Table (Typ)));
4248
4249                   procedure Copy_Secondary_DTs (Typ : Entity_Id);
4250                   --  Local procedure required to climb through the ancestors
4251                   --  and copy the contents of all their secondary dispatch
4252                   --  tables.
4253
4254                   ------------------------
4255                   -- Copy_Secondary_DTs --
4256                   ------------------------
4257
4258                   procedure Copy_Secondary_DTs (Typ : Entity_Id) is
4259                      E     : Entity_Id;
4260                      Iface : Elmt_Id;
4261
4262                   begin
4263                      --  Climb to the ancestor (if any) handling private types
4264
4265                      if Present (Full_View (Etype (Typ))) then
4266                         if Full_View (Etype (Typ)) /= Typ then
4267                            Copy_Secondary_DTs (Full_View (Etype (Typ)));
4268                         end if;
4269
4270                      elsif Etype (Typ) /= Typ then
4271                         Copy_Secondary_DTs (Etype (Typ));
4272                      end if;
4273
4274                      if Present (Abstract_Interfaces (Typ))
4275                        and then not Is_Empty_Elmt_List
4276                                       (Abstract_Interfaces (Typ))
4277                      then
4278                         Iface := First_Elmt (Abstract_Interfaces (Typ));
4279                         E     := First_Entity (Typ);
4280                         while Present (E)
4281                           and then Present (Node (Sec_DT_Ancestor))
4282                           and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
4283                         loop
4284                            if Is_Tag (E) and then Chars (E) /= Name_uTag then
4285                               if not Is_Interface (Etype (Typ)) then
4286
4287                                  --  Inherit the dispatch table
4288
4289                                  declare
4290                                     Num_Prims : constant Int :=
4291                                                 UI_To_Int (DT_Entry_Count (E));
4292                                  begin
4293                                     Append_To (Elab_Code,
4294                                       Build_Inherit_Predefined_Prims (Loc,
4295                                         Old_Tag_Node =>
4296                                           Unchecked_Convert_To (RTE (RE_Tag),
4297                                              New_Reference_To
4298                                                (Node (Sec_DT_Ancestor), Loc)),
4299                                         New_Tag_Node =>
4300                                           Unchecked_Convert_To (RTE (RE_Tag),
4301                                             New_Reference_To
4302                                               (Node (Sec_DT_Typ), Loc))));
4303
4304                                     if Num_Prims /= 0 then
4305                                        Append_To (Elab_Code,
4306                                          Build_Inherit_Prims (Loc,
4307                                            Old_Tag_Node =>
4308                                              Unchecked_Convert_To
4309                                                (RTE (RE_Tag),
4310                                                 New_Reference_To
4311                                                   (Node (Sec_DT_Ancestor),
4312                                                    Loc)),
4313                                            New_Tag_Node =>
4314                                              Unchecked_Convert_To
4315                                               (RTE (RE_Tag),
4316                                                New_Reference_To
4317                                                  (Node (Sec_DT_Typ), Loc)),
4318                                            Num_Prims => Num_Prims));
4319                                     end if;
4320                                  end;
4321                               end if;
4322
4323                               Next_Elmt (Sec_DT_Ancestor);
4324                               Next_Elmt (Sec_DT_Typ);
4325                               Next_Elmt (Iface);
4326                            end if;
4327
4328                            Next_Entity (E);
4329                         end loop;
4330                      end if;
4331                   end Copy_Secondary_DTs;
4332
4333                begin
4334                   if Present (Node (Sec_DT_Ancestor))
4335                     and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
4336                   then
4337                      --  Handle private types
4338
4339                      if Present (Full_View (Typ)) then
4340                         Copy_Secondary_DTs (Full_View (Typ));
4341                      else
4342                         Copy_Secondary_DTs (Typ);
4343                      end if;
4344                   end if;
4345                end;
4346             end if;
4347          end if;
4348       end if;
4349
4350       --  Generate code to register the Tag in the External_Tag hash table for
4351       --  the pure Ada type only.
4352
4353       --        Register_Tag (Dt_Ptr);
4354
4355       --  Skip this action in the following cases:
4356       --    1) if Register_Tag is not available.
4357       --    2) in No_Run_Time mode.
4358       --    3) if Typ is an abstract interface type (the secondary tags will
4359       --       be registered later in types implementing this interface type).
4360       --    4) if Typ is not defined at the library level (this is required
4361       --       to avoid adding concurrency control to the hash table used
4362       --       by the run-time to register the tags).
4363
4364       --  Generate:
4365       --     if No_Reg then
4366       --        [ Elab_Code ]
4367       --        [ Register_Tag (Dt_Ptr); ]
4368       --        No_Reg := False;
4369       --     end if;
4370
4371       if not Is_Interface (Typ) then
4372          if not No_Run_Time_Mode
4373            and then not Is_Local_DT
4374            and then RTE_Available (RE_Register_Tag)
4375          then
4376             Append_To (Elab_Code,
4377               Make_Procedure_Call_Statement (Loc,
4378                 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
4379                 Parameter_Associations =>
4380                   New_List (New_Reference_To (DT_Ptr, Loc))));
4381          end if;
4382
4383          Append_To (Elab_Code,
4384            Make_Assignment_Statement (Loc,
4385              Name       => New_Reference_To (No_Reg, Loc),
4386              Expression => New_Reference_To (Standard_False, Loc)));
4387
4388          Append_To (Result,
4389            Make_Implicit_If_Statement (Typ,
4390              Condition       => New_Reference_To (No_Reg, Loc),
4391              Then_Statements => Elab_Code));
4392       end if;
4393
4394       Analyze_List (Result, Suppress => All_Checks);
4395       return Result;
4396    end Make_DT;
4397
4398    -------------------------------------
4399    -- Make_Select_Specific_Data_Table --
4400    -------------------------------------
4401
4402    function Make_Select_Specific_Data_Table
4403      (Typ : Entity_Id) return List_Id
4404    is
4405       Assignments : constant List_Id    := New_List;
4406       Loc         : constant Source_Ptr := Sloc (Typ);
4407
4408       Conc_Typ  : Entity_Id;
4409       Decls     : List_Id;
4410       DT_Ptr    : Entity_Id;
4411       Prim      : Entity_Id;
4412       Prim_Als  : Entity_Id;
4413       Prim_Elmt : Elmt_Id;
4414       Prim_Pos  : Uint;
4415       Nb_Prim   : Nat := 0;
4416
4417       type Examined_Array is array (Int range <>) of Boolean;
4418
4419       function Find_Entry_Index (E : Entity_Id) return Uint;
4420       --  Given an entry, find its index in the visible declarations of the
4421       --  corresponding concurrent type of Typ.
4422
4423       ----------------------
4424       -- Find_Entry_Index --
4425       ----------------------
4426
4427       function Find_Entry_Index (E : Entity_Id) return Uint is
4428          Index     : Uint := Uint_1;
4429          Subp_Decl : Entity_Id;
4430
4431       begin
4432          if Present (Decls)
4433            and then not Is_Empty_List (Decls)
4434          then
4435             Subp_Decl := First (Decls);
4436             while Present (Subp_Decl) loop
4437                if Nkind (Subp_Decl) = N_Entry_Declaration then
4438                   if Defining_Identifier (Subp_Decl) = E then
4439                      return Index;
4440                   end if;
4441
4442                   Index := Index + 1;
4443                end if;
4444
4445                Next (Subp_Decl);
4446             end loop;
4447          end if;
4448
4449          return Uint_0;
4450       end Find_Entry_Index;
4451
4452    --  Start of processing for Make_Select_Specific_Data_Table
4453
4454    begin
4455       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
4456
4457       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
4458
4459       if Present (Corresponding_Concurrent_Type (Typ)) then
4460          Conc_Typ := Corresponding_Concurrent_Type (Typ);
4461
4462          if Ekind (Conc_Typ) = E_Protected_Type then
4463             Decls := Visible_Declarations (Protected_Definition (
4464                        Parent (Conc_Typ)));
4465          else
4466             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
4467             Decls := Visible_Declarations (Task_Definition (
4468                        Parent (Conc_Typ)));
4469          end if;
4470       end if;
4471
4472       --  Count the non-predefined primitive operations
4473
4474       Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4475       while Present (Prim_Elmt) loop
4476          Prim := Node (Prim_Elmt);
4477
4478          if not (Is_Predefined_Dispatching_Operation (Prim)
4479                    or else Is_Predefined_Dispatching_Alias (Prim))
4480          then
4481             Nb_Prim := Nb_Prim + 1;
4482          end if;
4483
4484          Next_Elmt (Prim_Elmt);
4485       end loop;
4486
4487       declare
4488          Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
4489
4490       begin
4491          Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4492          while Present (Prim_Elmt) loop
4493             Prim := Node (Prim_Elmt);
4494
4495             --  Look for primitive overriding an abstract interface subprogram
4496
4497             if Present (Abstract_Interface_Alias (Prim))
4498               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
4499             then
4500                Prim_Pos := DT_Position (Alias (Prim));
4501                pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
4502                Examined (UI_To_Int (Prim_Pos)) := True;
4503
4504                --  Set the primitive operation kind regardless of subprogram
4505                --  type. Generate:
4506                --    Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
4507
4508                Append_To (Assignments,
4509                  Make_Procedure_Call_Statement (Loc,
4510                    Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
4511                    Parameter_Associations => New_List (
4512                      New_Reference_To (DT_Ptr, Loc),
4513                      Make_Integer_Literal (Loc, Prim_Pos),
4514                      Prim_Op_Kind (Alias (Prim), Typ))));
4515
4516                --  Retrieve the root of the alias chain
4517
4518                Prim_Als := Prim;
4519                while Present (Alias (Prim_Als)) loop
4520                   Prim_Als := Alias (Prim_Als);
4521                end loop;
4522
4523                --  In the case of an entry wrapper, set the entry index
4524
4525                if Ekind (Prim) = E_Procedure
4526                  and then Is_Primitive_Wrapper (Prim_Als)
4527                  and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
4528                then
4529                   --  Generate:
4530                   --    Ada.Tags.Set_Entry_Index
4531                   --      (DT_Ptr, <position>, <index>);
4532
4533                   Append_To (Assignments,
4534                     Make_Procedure_Call_Statement (Loc,
4535                       Name =>
4536                         New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
4537                       Parameter_Associations => New_List (
4538                         New_Reference_To (DT_Ptr, Loc),
4539                         Make_Integer_Literal (Loc, Prim_Pos),
4540                         Make_Integer_Literal (Loc,
4541                           Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
4542                end if;
4543             end if;
4544
4545             Next_Elmt (Prim_Elmt);
4546          end loop;
4547       end;
4548
4549       return Assignments;
4550    end Make_Select_Specific_Data_Table;
4551
4552    -----------------------------------
4553    -- Original_View_In_Visible_Part --
4554    -----------------------------------
4555
4556    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
4557       Scop : constant Entity_Id := Scope (Typ);
4558
4559    begin
4560       --  The scope must be a package
4561
4562       if Ekind (Scop) /= E_Package
4563         and then Ekind (Scop) /= E_Generic_Package
4564       then
4565          return False;
4566       end if;
4567
4568       --  A type with a private declaration has a private view declared in
4569       --  the visible part.
4570
4571       if Has_Private_Declaration (Typ) then
4572          return True;
4573       end if;
4574
4575       return List_Containing (Parent (Typ)) =
4576         Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
4577    end Original_View_In_Visible_Part;
4578
4579    ------------------
4580    -- Prim_Op_Kind --
4581    ------------------
4582
4583    function Prim_Op_Kind
4584      (Prim : Entity_Id;
4585       Typ  : Entity_Id) return Node_Id
4586    is
4587       Full_Typ : Entity_Id := Typ;
4588       Loc      : constant Source_Ptr := Sloc (Prim);
4589       Prim_Op  : Entity_Id;
4590
4591    begin
4592       --  Retrieve the original primitive operation
4593
4594       Prim_Op := Prim;
4595       while Present (Alias (Prim_Op)) loop
4596          Prim_Op := Alias (Prim_Op);
4597       end loop;
4598
4599       if Ekind (Typ) = E_Record_Type
4600         and then Present (Corresponding_Concurrent_Type (Typ))
4601       then
4602          Full_Typ := Corresponding_Concurrent_Type (Typ);
4603       end if;
4604
4605       if Ekind (Prim_Op) = E_Function then
4606
4607          --  Protected function
4608
4609          if Ekind (Full_Typ) = E_Protected_Type then
4610             return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
4611
4612          --  Task function
4613
4614          elsif Ekind (Full_Typ) = E_Task_Type then
4615             return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
4616
4617          --  Regular function
4618
4619          else
4620             return New_Reference_To (RTE (RE_POK_Function), Loc);
4621          end if;
4622
4623       else
4624          pragma Assert (Ekind (Prim_Op) = E_Procedure);
4625
4626          if Ekind (Full_Typ) = E_Protected_Type then
4627
4628             --  Protected entry
4629
4630             if Is_Primitive_Wrapper (Prim_Op)
4631               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
4632             then
4633                return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
4634
4635             --  Protected procedure
4636
4637             else
4638                return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
4639             end if;
4640
4641          elsif Ekind (Full_Typ) = E_Task_Type then
4642
4643             --  Task entry
4644
4645             if Is_Primitive_Wrapper (Prim_Op)
4646               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
4647             then
4648                return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
4649
4650             --  Task "procedure". These are the internally Expander-generated
4651             --  procedures (task body for instance).
4652
4653             else
4654                return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
4655             end if;
4656
4657          --  Regular procedure
4658
4659          else
4660             return New_Reference_To (RTE (RE_POK_Procedure), Loc);
4661          end if;
4662       end if;
4663    end Prim_Op_Kind;
4664
4665    ------------------------
4666    -- Register_Primitive --
4667    ------------------------
4668
4669    procedure Register_Primitive
4670      (Loc     : Source_Ptr;
4671       Prim    : Entity_Id;
4672       Ins_Nod : Node_Id)
4673    is
4674       DT_Ptr       : Entity_Id;
4675       Iface_Prim   : Entity_Id;
4676       Iface_Typ    : Entity_Id;
4677       Iface_DT_Ptr : Entity_Id;
4678       Pos          : Uint;
4679       Tag          : Entity_Id;
4680       Thunk_Id     : Entity_Id;
4681       Thunk_Code   : Node_Id;
4682       Typ          : Entity_Id;
4683
4684    begin
4685       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
4686
4687       if not RTE_Available (RE_Tag) then
4688          return;
4689       end if;
4690
4691       if not Present (Abstract_Interface_Alias (Prim)) then
4692          Typ          := Scope (DTC_Entity (Prim));
4693          DT_Ptr       := Node (First_Elmt (Access_Disp_Table (Typ)));
4694          Pos          := DT_Position (Prim);
4695          Tag          := First_Tag_Component (Typ);
4696
4697          if Is_Predefined_Dispatching_Operation (Prim)
4698            or else Is_Predefined_Dispatching_Alias (Prim)
4699          then
4700             Insert_After (Ins_Nod,
4701               Build_Set_Predefined_Prim_Op_Address (Loc,
4702                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
4703                 Position     => Pos,
4704                 Address_Node => Make_Attribute_Reference (Loc,
4705                                    Prefix => New_Reference_To (Prim, Loc),
4706                                    Attribute_Name => Name_Address)));
4707
4708          else
4709             pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
4710
4711             Insert_After (Ins_Nod,
4712               Build_Set_Prim_Op_Address (Loc,
4713                 Typ          => Typ,
4714                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
4715                 Position     => Pos,
4716                 Address_Node => Make_Attribute_Reference (Loc,
4717                                   Prefix => New_Reference_To (Prim, Loc),
4718                                   Attribute_Name => Name_Address)));
4719          end if;
4720
4721       --  Ada 2005 (AI-251): Primitive associated with an interface type
4722       --  Generate the code of the thunk only if the interface type is not an
4723       --  immediate ancestor of Typ; otherwise the dispatch table associated
4724       --  with the interface is the primary dispatch table and we have nothing
4725       --  else to do here.
4726
4727       else
4728          Typ       := Find_Dispatching_Type (Alias (Prim));
4729          Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim));
4730
4731          pragma Assert (Is_Interface (Iface_Typ));
4732
4733          Expand_Interface_Thunk
4734            (N           => Prim,
4735             Thunk_Alias => Alias (Prim),
4736             Thunk_Id    => Thunk_Id,
4737             Thunk_Code  => Thunk_Code);
4738
4739          if not Is_Parent (Iface_Typ, Typ)
4740            and then Present (Thunk_Code)
4741          then
4742             Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks);
4743
4744             --  Generate the code necessary to fill the appropriate entry of
4745             --  the secondary dispatch table of Prim's controlling type with
4746             --  Thunk_Id's address.
4747
4748             Iface_DT_Ptr := Find_Interface_ADT (Typ, Iface_Typ);
4749             Iface_Prim   := Abstract_Interface_Alias (Prim);
4750             Pos          := DT_Position (Iface_Prim);
4751             Tag          := First_Tag_Component (Iface_Typ);
4752
4753             if Is_Predefined_Dispatching_Operation (Prim)
4754               or else Is_Predefined_Dispatching_Alias (Prim)
4755             then
4756                Insert_Action (Ins_Nod,
4757                  Build_Set_Predefined_Prim_Op_Address (Loc,
4758                    Tag_Node => New_Reference_To (Iface_DT_Ptr, Loc),
4759                    Position => Pos,
4760                    Address_Node =>
4761                      Make_Attribute_Reference (Loc,
4762                        Prefix          => New_Reference_To (Thunk_Id, Loc),
4763                        Attribute_Name  => Name_Address)));
4764             else
4765                pragma Assert (Pos /= Uint_0
4766                  and then Pos <= DT_Entry_Count (Tag));
4767
4768                Insert_Action (Ins_Nod,
4769                  Build_Set_Prim_Op_Address (Loc,
4770                    Typ          => Iface_Typ,
4771                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
4772                    Position     => Pos,
4773                    Address_Node => Make_Attribute_Reference (Loc,
4774                                      Prefix =>
4775                                         New_Reference_To (Thunk_Id, Loc),
4776                                      Attribute_Name => Name_Address)));
4777             end if;
4778          end if;
4779       end if;
4780    end Register_Primitive;
4781
4782    -------------------------
4783    -- Set_All_DT_Position --
4784    -------------------------
4785
4786    procedure Set_All_DT_Position (Typ : Entity_Id) is
4787
4788       procedure Validate_Position (Prim : Entity_Id);
4789       --  Check that the position assignated to Prim is completely safe
4790       --  (it has not been assigned to a previously defined primitive
4791       --   operation of Typ)
4792
4793       -----------------------
4794       -- Validate_Position --
4795       -----------------------
4796
4797       procedure Validate_Position (Prim : Entity_Id) is
4798          Op_Elmt : Elmt_Id;
4799          Op      : Entity_Id;
4800
4801       begin
4802          --  Aliased primitives are safe
4803
4804          if Present (Alias (Prim)) then
4805             return;
4806          end if;
4807
4808          Op_Elmt := First_Elmt (Primitive_Operations (Typ));
4809          while Present (Op_Elmt) loop
4810             Op := Node (Op_Elmt);
4811
4812             --  No need to check against itself
4813
4814             if Op = Prim then
4815                null;
4816
4817             --  Primitive operations covering abstract interfaces are
4818             --  allocated later
4819
4820             elsif Present (Abstract_Interface_Alias (Op)) then
4821                null;
4822
4823             --  Predefined dispatching operations are completely safe. They
4824             --  are allocated at fixed positions in a separate table.
4825
4826             elsif Is_Predefined_Dispatching_Operation (Op)
4827                or else Is_Predefined_Dispatching_Alias (Op)
4828             then
4829                null;
4830
4831             --  Aliased subprograms are safe
4832
4833             elsif Present (Alias (Op)) then
4834                null;
4835
4836             elsif DT_Position (Op) = DT_Position (Prim)
4837                and then not Is_Predefined_Dispatching_Operation (Op)
4838                and then not Is_Predefined_Dispatching_Operation (Prim)
4839                and then not Is_Predefined_Dispatching_Alias (Op)
4840                and then not Is_Predefined_Dispatching_Alias (Prim)
4841             then
4842
4843                --  Handle aliased subprograms
4844
4845                declare
4846                   Op_1 : Entity_Id;
4847                   Op_2 : Entity_Id;
4848
4849                begin
4850                   Op_1 := Op;
4851                   loop
4852                      if Present (Overridden_Operation (Op_1)) then
4853                         Op_1 := Overridden_Operation (Op_1);
4854                      elsif Present (Alias (Op_1)) then
4855                         Op_1 := Alias (Op_1);
4856                      else
4857                         exit;
4858                      end if;
4859                   end loop;
4860
4861                   Op_2 := Prim;
4862                   loop
4863                      if Present (Overridden_Operation (Op_2)) then
4864                         Op_2 := Overridden_Operation (Op_2);
4865                      elsif Present (Alias (Op_2)) then
4866                         Op_2 := Alias (Op_2);
4867                      else
4868                         exit;
4869                      end if;
4870                   end loop;
4871
4872                   if Op_1 /= Op_2 then
4873                      raise Program_Error;
4874                   end if;
4875                end;
4876             end if;
4877
4878             Next_Elmt (Op_Elmt);
4879          end loop;
4880       end Validate_Position;
4881
4882       --  Local variables
4883
4884       Parent_Typ : constant Entity_Id := Etype (Typ);
4885       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
4886       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
4887
4888       Adjusted   : Boolean := False;
4889       Finalized  : Boolean := False;
4890
4891       Count_Prim : Nat;
4892       DT_Length  : Nat;
4893       Nb_Prim    : Nat;
4894       Prim       : Entity_Id;
4895       Prim_Elmt  : Elmt_Id;
4896
4897    --  Start of processing for Set_All_DT_Position
4898
4899    begin
4900       --  Set the DT_Position for each primitive operation. Perform some
4901       --  sanity checks to avoid to build completely inconsistant dispatch
4902       --  tables.
4903
4904       --  First stage: Set the DTC entity of all the primitive operations
4905       --  This is required to properly read the DT_Position attribute in
4906       --  the latter stages.
4907
4908       Prim_Elmt  := First_Prim;
4909       Count_Prim := 0;
4910       while Present (Prim_Elmt) loop
4911          Prim := Node (Prim_Elmt);
4912
4913          --  Predefined primitives have a separate dispatch table
4914
4915          if not (Is_Predefined_Dispatching_Operation (Prim)
4916                    or else Is_Predefined_Dispatching_Alias (Prim))
4917          then
4918             Count_Prim := Count_Prim + 1;
4919          end if;
4920
4921          Set_DTC_Entity_Value (Typ, Prim);
4922
4923          --  Clear any previous value of the DT_Position attribute. In this
4924          --  way we ensure that the final position of all the primitives is
4925          --  stablished by the following stages of this algorithm.
4926
4927          Set_DT_Position (Prim, No_Uint);
4928
4929          Next_Elmt (Prim_Elmt);
4930       end loop;
4931
4932       declare
4933          Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean
4934                         := (others => False);
4935          E : Entity_Id;
4936
4937          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
4938          --  Called if Typ is declared in a nested package or a public child
4939          --  package to handle inherited primitives that were inherited by Typ
4940          --  in  the visible part, but whose declaration was deferred because
4941          --  the parent operation was private and not visible at that point.
4942
4943          procedure Set_Fixed_Prim (Pos : Nat);
4944          --  Sets to true an element of the Fixed_Prim table to indicate
4945          --  that this entry of the dispatch table of Typ is occupied.
4946
4947          ------------------------------------------
4948          -- Handle_Inherited_Private_Subprograms --
4949          ------------------------------------------
4950
4951          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
4952             Op_List     : Elist_Id;
4953             Op_Elmt     : Elmt_Id;
4954             Op_Elmt_2   : Elmt_Id;
4955             Prim_Op     : Entity_Id;
4956             Parent_Subp : Entity_Id;
4957
4958          begin
4959             Op_List := Primitive_Operations (Typ);
4960
4961             Op_Elmt := First_Elmt (Op_List);
4962             while Present (Op_Elmt) loop
4963                Prim_Op := Node (Op_Elmt);
4964
4965                --  Search primitives that are implicit operations with an
4966                --  internal name whose parent operation has a normal name.
4967
4968                if Present (Alias (Prim_Op))
4969                  and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
4970                  and then not Comes_From_Source (Prim_Op)
4971                  and then Is_Internal_Name (Chars (Prim_Op))
4972                  and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
4973                then
4974                   Parent_Subp := Alias (Prim_Op);
4975
4976                   --  Check if the type has an explicit overriding for this
4977                   --  primitive.
4978
4979                   Op_Elmt_2 := Next_Elmt (Op_Elmt);
4980                   while Present (Op_Elmt_2) loop
4981                      if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
4982                        and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
4983                      then
4984                         Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
4985                         Set_DT_Position (Node (Op_Elmt_2),
4986                           DT_Position (Parent_Subp));
4987                         Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
4988
4989                         goto Next_Primitive;
4990                      end if;
4991
4992                      Next_Elmt (Op_Elmt_2);
4993                   end loop;
4994                end if;
4995
4996                <<Next_Primitive>>
4997                Next_Elmt (Op_Elmt);
4998             end loop;
4999          end Handle_Inherited_Private_Subprograms;
5000
5001          --------------------
5002          -- Set_Fixed_Prim --
5003          --------------------
5004
5005          procedure Set_Fixed_Prim (Pos : Nat) is
5006          begin
5007             pragma Assert (Pos >= 0 and then Pos <= Count_Prim);
5008             Fixed_Prim (Pos) := True;
5009          exception
5010             when Constraint_Error =>
5011                raise Program_Error;
5012          end Set_Fixed_Prim;
5013
5014       begin
5015          --  In case of nested packages and public child package it may be
5016          --  necessary a special management on inherited subprograms so that
5017          --  the dispatch table is properly filled.
5018
5019          if Ekind (Scope (Scope (Typ))) = E_Package
5020            and then Scope (Scope (Typ)) /= Standard_Standard
5021            and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
5022                        or else
5023                         (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
5024                           and then Is_Generic_Type (Typ)))
5025            and then In_Open_Scopes (Scope (Etype (Typ)))
5026            and then Typ = Base_Type (Typ)
5027          then
5028             Handle_Inherited_Private_Subprograms (Typ);
5029          end if;
5030
5031          --  Second stage: Register fixed entries
5032
5033          Nb_Prim   := 0;
5034          Prim_Elmt := First_Prim;
5035          while Present (Prim_Elmt) loop
5036             Prim := Node (Prim_Elmt);
5037
5038             --  Predefined primitives have a separate table and all its
5039             --  entries are at predefined fixed positions.
5040
5041             if Is_Predefined_Dispatching_Operation (Prim) then
5042                Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
5043
5044             elsif Is_Predefined_Dispatching_Alias (Prim) then
5045                E := Alias (Prim);
5046                while Present (Alias (E)) loop
5047                   E := Alias (E);
5048                end loop;
5049
5050                Set_DT_Position (Prim, Default_Prim_Op_Position (E));
5051
5052             --  Overriding primitives of ancestor abstract interfaces
5053
5054             elsif Present (Abstract_Interface_Alias (Prim))
5055               and then Is_Parent
5056                          (Find_Dispatching_Type
5057                            (Abstract_Interface_Alias (Prim)),
5058                           Typ)
5059             then
5060                pragma Assert (DT_Position (Prim) = No_Uint
5061                  and then Present (DTC_Entity
5062                                     (Abstract_Interface_Alias (Prim))));
5063
5064                E := Abstract_Interface_Alias (Prim);
5065                Set_DT_Position (Prim, DT_Position (E));
5066
5067                pragma Assert
5068                  (DT_Position (Alias (Prim)) = No_Uint
5069                     or else DT_Position (Alias (Prim)) = DT_Position (E));
5070                Set_DT_Position (Alias (Prim), DT_Position (E));
5071                Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
5072
5073             --  Overriding primitives must use the same entry as the
5074             --  overriden primitive.
5075
5076             elsif not Present (Abstract_Interface_Alias (Prim))
5077               and then Present (Alias (Prim))
5078               and then Find_Dispatching_Type (Alias (Prim)) /= Typ
5079               and then Is_Parent
5080                          (Find_Dispatching_Type (Alias (Prim)), Typ)
5081               and then Present (DTC_Entity (Alias (Prim)))
5082             then
5083                E := Alias (Prim);
5084                Set_DT_Position (Prim, DT_Position (E));
5085
5086                if not Is_Predefined_Dispatching_Alias (E) then
5087                   Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
5088                end if;
5089             end if;
5090
5091             Next_Elmt (Prim_Elmt);
5092          end loop;
5093
5094          --  Third stage: Fix the position of all the new primitives
5095          --  Entries associated with primitives covering interfaces
5096          --  are handled in a latter round.
5097
5098          Prim_Elmt := First_Prim;
5099          while Present (Prim_Elmt) loop
5100             Prim := Node (Prim_Elmt);
5101
5102             --  Skip primitives previously set entries
5103
5104             if DT_Position (Prim) /= No_Uint then
5105                null;
5106
5107             --  Primitives covering interface primitives are handled later
5108
5109             elsif Present (Abstract_Interface_Alias (Prim)) then
5110                null;
5111
5112             else
5113                --  Take the next available position in the DT
5114
5115                loop
5116                   Nb_Prim := Nb_Prim + 1;
5117                   pragma Assert (Nb_Prim <= Count_Prim);
5118                   exit when not Fixed_Prim (Nb_Prim);
5119                end loop;
5120
5121                Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
5122                Set_Fixed_Prim (Nb_Prim);
5123             end if;
5124
5125             Next_Elmt (Prim_Elmt);
5126          end loop;
5127       end;
5128
5129       --  Fourth stage: Complete the decoration of primitives covering
5130       --  interfaces (that is, propagate the DT_Position attribute
5131       --  from the aliased primitive)
5132
5133       Prim_Elmt := First_Prim;
5134       while Present (Prim_Elmt) loop
5135          Prim := Node (Prim_Elmt);
5136
5137          if DT_Position (Prim) = No_Uint
5138            and then Present (Abstract_Interface_Alias (Prim))
5139          then
5140             pragma Assert (Present (Alias (Prim))
5141               and then Find_Dispatching_Type (Alias (Prim)) = Typ);
5142
5143             --  Check if this entry will be placed in the primary DT
5144
5145             if Is_Parent (Find_Dispatching_Type
5146                            (Abstract_Interface_Alias (Prim)),
5147                           Typ)
5148             then
5149                pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
5150                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
5151
5152             --  Otherwise it will be placed in the secondary DT
5153
5154             else
5155                pragma Assert
5156                  (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
5157                Set_DT_Position (Prim,
5158                  DT_Position (Abstract_Interface_Alias (Prim)));
5159             end if;
5160          end if;
5161
5162          Next_Elmt (Prim_Elmt);
5163       end loop;
5164
5165       --  Generate listing showing the contents of the dispatch tables.
5166       --  This action is done before some further static checks because
5167       --  in case of critical errors caused by a wrong dispatch table
5168       --  we need to see the contents of such table.
5169
5170       if Debug_Flag_ZZ then
5171          Write_DT (Typ);
5172       end if;
5173
5174       --  Final stage: Ensure that the table is correct plus some further
5175       --  verifications concerning the primitives.
5176
5177       Prim_Elmt := First_Prim;
5178       DT_Length := 0;
5179       while Present (Prim_Elmt) loop
5180          Prim := Node (Prim_Elmt);
5181
5182          --  At this point all the primitives MUST have a position
5183          --  in the dispatch table
5184
5185          if DT_Position (Prim) = No_Uint then
5186             raise Program_Error;
5187          end if;
5188
5189          --  Calculate real size of the dispatch table
5190
5191          if not (Is_Predefined_Dispatching_Operation (Prim)
5192                    or else Is_Predefined_Dispatching_Alias (Prim))
5193            and then UI_To_Int (DT_Position (Prim)) > DT_Length
5194          then
5195             DT_Length := UI_To_Int (DT_Position (Prim));
5196          end if;
5197
5198          --  Ensure that the asignated position to non-predefined
5199          --  dispatching operations in the dispatch table is correct.
5200
5201          if not (Is_Predefined_Dispatching_Operation (Prim)
5202                    or else Is_Predefined_Dispatching_Alias (Prim))
5203          then
5204             Validate_Position (Prim);
5205          end if;
5206
5207          if Chars (Prim) = Name_Finalize then
5208             Finalized := True;
5209          end if;
5210
5211          if Chars (Prim) = Name_Adjust then
5212             Adjusted := True;
5213          end if;
5214
5215          --  An abstract operation cannot be declared in the private part
5216          --  for a visible abstract type, because it could never be over-
5217          --  ridden. For explicit declarations this is checked at the
5218          --  point of declaration, but for inherited operations it must
5219          --  be done when building the dispatch table.
5220
5221          --  Ada 2005 (AI-251): Hidden entities associated with abstract
5222          --  interface primitives are not taken into account because the
5223          --  check is done with the aliased primitive.
5224
5225          if Is_Abstract_Type (Typ)
5226            and then Is_Abstract_Subprogram (Prim)
5227            and then Present (Alias (Prim))
5228            and then not Present (Abstract_Interface_Alias (Prim))
5229            and then Is_Derived_Type (Typ)
5230            and then In_Private_Part (Current_Scope)
5231            and then
5232              List_Containing (Parent (Prim)) =
5233                Private_Declarations
5234                 (Specification (Unit_Declaration_Node (Current_Scope)))
5235            and then Original_View_In_Visible_Part (Typ)
5236          then
5237             --  We exclude Input and Output stream operations because
5238             --  Limited_Controlled inherits useless Input and Output
5239             --  stream operations from Root_Controlled, which can
5240             --  never be overridden.
5241
5242             if not Is_TSS (Prim, TSS_Stream_Input)
5243                  and then
5244                not Is_TSS (Prim, TSS_Stream_Output)
5245             then
5246                Error_Msg_NE
5247                  ("abstract inherited private operation&" &
5248                   " must be overridden ('R'M 3.9.3(10))",
5249                  Parent (Typ), Prim);
5250             end if;
5251          end if;
5252
5253          Next_Elmt (Prim_Elmt);
5254       end loop;
5255
5256       --  Additional check
5257
5258       if Is_Controlled (Typ) then
5259          if not Finalized then
5260             Error_Msg_N
5261               ("controlled type has no explicit Finalize method?", Typ);
5262
5263          elsif not Adjusted then
5264             Error_Msg_N
5265               ("controlled type has no explicit Adjust method?", Typ);
5266          end if;
5267       end if;
5268
5269       --  Set the final size of the Dispatch Table
5270
5271       Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
5272
5273       --  The derived type must have at least as many components as its parent
5274       --  (for root types, the Etype points back to itself and the test cannot
5275       --   fail)
5276
5277       if DT_Entry_Count (The_Tag) <
5278            DT_Entry_Count (First_Tag_Component (Parent_Typ))
5279       then
5280          raise Program_Error;
5281       end if;
5282    end Set_All_DT_Position;
5283
5284    -----------------------------
5285    -- Set_Default_Constructor --
5286    -----------------------------
5287
5288    procedure Set_Default_Constructor (Typ : Entity_Id) is
5289       Loc   : Source_Ptr;
5290       Init  : Entity_Id;
5291       Param : Entity_Id;
5292       E     : Entity_Id;
5293
5294    begin
5295       --  Look for the default constructor entity. For now only the
5296       --  default constructor has the flag Is_Constructor.
5297
5298       E := Next_Entity (Typ);
5299       while Present (E)
5300         and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
5301       loop
5302          Next_Entity (E);
5303       end loop;
5304
5305       --  Create the init procedure
5306
5307       if Present (E) then
5308          Loc   := Sloc (E);
5309          Init  := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
5310          Param := Make_Defining_Identifier (Loc, Name_X);
5311
5312          Discard_Node (
5313            Make_Subprogram_Declaration (Loc,
5314              Make_Procedure_Specification (Loc,
5315                Defining_Unit_Name => Init,
5316                Parameter_Specifications => New_List (
5317                  Make_Parameter_Specification (Loc,
5318                    Defining_Identifier => Param,
5319                    Parameter_Type      => New_Reference_To (Typ, Loc))))));
5320
5321          Set_Init_Proc (Typ, Init);
5322          Set_Is_Imported    (Init);
5323          Set_Interface_Name (Init, Interface_Name (E));
5324          Set_Convention     (Init, Convention_C);
5325          Set_Is_Public      (Init);
5326          Set_Has_Completion (Init);
5327
5328       --  If there are no constructors, mark the type as abstract since we
5329       --  won't be able to declare objects of that type.
5330
5331       else
5332          Set_Is_Abstract_Type (Typ);
5333       end if;
5334    end Set_Default_Constructor;
5335
5336    --------------------------
5337    -- Set_DTC_Entity_Value --
5338    --------------------------
5339
5340    procedure Set_DTC_Entity_Value
5341      (Tagged_Type : Entity_Id;
5342       Prim        : Entity_Id)
5343    is
5344    begin
5345       if Present (Abstract_Interface_Alias (Prim))
5346         and then Is_Interface
5347                    (Find_Dispatching_Type
5348                      (Abstract_Interface_Alias (Prim)))
5349       then
5350          Set_DTC_Entity (Prim,
5351            Find_Interface_Tag
5352              (T     => Tagged_Type,
5353               Iface => Find_Dispatching_Type
5354                         (Abstract_Interface_Alias (Prim))));
5355       else
5356          Set_DTC_Entity (Prim,
5357            First_Tag_Component (Tagged_Type));
5358       end if;
5359    end Set_DTC_Entity_Value;
5360
5361    -----------------
5362    -- Tagged_Kind --
5363    -----------------
5364
5365    function Tagged_Kind (T : Entity_Id) return Node_Id is
5366       Conc_Typ : Entity_Id;
5367       Loc      : constant Source_Ptr := Sloc (T);
5368
5369    begin
5370       pragma Assert
5371         (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
5372
5373       --  Abstract kinds
5374
5375       if Is_Abstract_Type (T) then
5376          if Is_Limited_Record (T) then
5377             return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
5378          else
5379             return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
5380          end if;
5381
5382       --  Concurrent kinds
5383
5384       elsif Is_Concurrent_Record_Type (T) then
5385          Conc_Typ := Corresponding_Concurrent_Type (T);
5386
5387          if Ekind (Conc_Typ) = E_Protected_Type then
5388             return New_Reference_To (RTE (RE_TK_Protected), Loc);
5389          else
5390             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
5391             return New_Reference_To (RTE (RE_TK_Task), Loc);
5392          end if;
5393
5394       --  Regular tagged kinds
5395
5396       else
5397          if Is_Limited_Record (T) then
5398             return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
5399          else
5400             return New_Reference_To (RTE (RE_TK_Tagged), Loc);
5401          end if;
5402       end if;
5403    end Tagged_Kind;
5404
5405    --------------
5406    -- Write_DT --
5407    --------------
5408
5409    procedure Write_DT (Typ : Entity_Id) is
5410       Elmt : Elmt_Id;
5411       Prim : Node_Id;
5412
5413    begin
5414       --  Protect this procedure against wrong usage. Required because it will
5415       --  be used directly from GDB
5416
5417       if not (Typ in First_Node_Id .. Last_Node_Id)
5418         or else not Is_Tagged_Type (Typ)
5419       then
5420          Write_Str ("wrong usage: Write_DT must be used with tagged types");
5421          Write_Eol;
5422          return;
5423       end if;
5424
5425       Write_Int (Int (Typ));
5426       Write_Str (": ");
5427       Write_Name (Chars (Typ));
5428
5429       if Is_Interface (Typ) then
5430          Write_Str (" is interface");
5431       end if;
5432
5433       Write_Eol;
5434
5435       Elmt := First_Elmt (Primitive_Operations (Typ));
5436       while Present (Elmt) loop
5437          Prim := Node (Elmt);
5438          Write_Str  (" - ");
5439
5440          --  Indicate if this primitive will be allocated in the primary
5441          --  dispatch table or in a secondary dispatch table associated
5442          --  with an abstract interface type
5443
5444          if Present (DTC_Entity (Prim)) then
5445             if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
5446                Write_Str ("[P] ");
5447             else
5448                Write_Str ("[s] ");
5449             end if;
5450          end if;
5451
5452          --  Output the node of this primitive operation and its name
5453
5454          Write_Int  (Int (Prim));
5455          Write_Str  (": ");
5456
5457          if Is_Predefined_Dispatching_Operation (Prim) then
5458             Write_Str ("(predefined) ");
5459          end if;
5460
5461          Write_Name (Chars (Prim));
5462
5463          --  Indicate if this primitive has an aliased primitive
5464
5465          if Present (Alias (Prim)) then
5466             Write_Str (" (alias = ");
5467             Write_Int (Int (Alias (Prim)));
5468
5469             --  If the DTC_Entity attribute is already set we can also output
5470             --  the name of the interface covered by this primitive (if any)
5471
5472             if Present (DTC_Entity (Alias (Prim)))
5473               and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
5474             then
5475                Write_Str  (" from interface ");
5476                Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
5477             end if;
5478
5479             if Present (Abstract_Interface_Alias (Prim)) then
5480                Write_Str  (", AI_Alias of ");
5481                Write_Name (Chars (Scope (DTC_Entity
5482                                           (Abstract_Interface_Alias (Prim)))));
5483                Write_Char (':');
5484                Write_Int  (Int (Abstract_Interface_Alias (Prim)));
5485             end if;
5486
5487             Write_Str (")");
5488          end if;
5489
5490          --  Display the final position of this primitive in its associated
5491          --  (primary or secondary) dispatch table
5492
5493          if Present (DTC_Entity (Prim))
5494            and then DT_Position (Prim) /= No_Uint
5495          then
5496             Write_Str (" at #");
5497             Write_Int (UI_To_Int (DT_Position (Prim)));
5498          end if;
5499
5500          if Is_Abstract_Subprogram (Prim) then
5501             Write_Str (" is abstract;");
5502
5503          --  Check if this is a null primitive
5504
5505          elsif Comes_From_Source (Prim)
5506            and then Ekind (Prim) = E_Procedure
5507            and then Null_Present (Parent (Prim))
5508          then
5509             Write_Str (" is null;");
5510          end if;
5511
5512          Write_Eol;
5513
5514          Next_Elmt (Elmt);
5515       end loop;
5516    end Write_DT;
5517
5518 end Exp_Disp;