gcc/ada/exp_disp.adb

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