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