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_Elmt : Elmt_Id;
3945             Frnodes   : List_Id;
3946
3947          begin
3948             Freezing_Library_Level_Tagged_Type := True;
3949             Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
3950             while Present (Prim_Elmt) loop
3951                Frnodes := Freeze_Entity (Node (Prim_Elmt), Loc);
3952
3953                declare
3954                   Subp : constant Entity_Id := Node (Prim_Elmt);
3955                   F : Entity_Id;
3956
3957                begin
3958                   F := First_Formal (Subp);
3959                   while Present (F) loop
3960                      Check_Premature_Freezing (Subp, Etype (F));
3961                      Next_Formal (F);
3962                   end loop;
3963
3964                   Check_Premature_Freezing (Subp, Etype (Subp));
3965                end;
3966
3967                if Present (Frnodes) then
3968                   Append_List_To (Result, Frnodes);
3969                end if;
3970
3971                Next_Elmt (Prim_Elmt);
3972             end loop;
3973             Freezing_Library_Level_Tagged_Type := Save;
3974          end;
3975       end if;
3976
3977       --  Ada 2005 (AI-251): Build the secondary dispatch tables
3978
3979       if Has_Interfaces (Typ) then
3980          Collect_Interface_Components (Typ, Typ_Comps);
3981
3982          --  Each secondary dispatch table is assigned an unique positive
3983          --  suffix index; such value also corresponds with the location of
3984          --  its entity in the Dispatch_Table_Wrappers list (see Make_Tags).
3985
3986          --  Note: This value must be kept sync with the Suffix_Index values
3987          --  generated by Make_Tags
3988
3989          Suffix_Index := 1;
3990          AI_Tag_Elmt  :=
3991            Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
3992
3993          AI_Tag_Comp := First_Elmt (Typ_Comps);
3994          while Present (AI_Tag_Comp) loop
3995
3996             --  Build the secondary table containing pointers to thunks
3997
3998             Make_Secondary_DT
3999              (Typ             => Typ,
4000               Iface           => Base_Type (Related_Type (Node (AI_Tag_Comp))),
4001               Suffix_Index    => Suffix_Index,
4002               Num_Iface_Prims => UI_To_Int
4003                                    (DT_Entry_Count (Node (AI_Tag_Comp))),
4004               Iface_DT_Ptr    => Node (AI_Tag_Elmt),
4005               Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4006               Build_Thunks    => True,
4007               Result          => Result);
4008
4009             --  Skip secondary dispatch table and secondary dispatch table of
4010             --  predefined primitives
4011
4012             Next_Elmt (AI_Tag_Elmt);
4013             Next_Elmt (AI_Tag_Elmt);
4014
4015             --  Build the secondary table containing pointers to primitives
4016             --  (used to give support to Generic Dispatching Constructors).
4017
4018             Make_Secondary_DT
4019              (Typ             => Typ,
4020               Iface           => Base_Type (Related_Type (Node (AI_Tag_Comp))),
4021               Suffix_Index    => -1,
4022               Num_Iface_Prims =>  UI_To_Int
4023                                    (DT_Entry_Count (Node (AI_Tag_Comp))),
4024               Iface_DT_Ptr    => Node (AI_Tag_Elmt),
4025               Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
4026               Build_Thunks    => False,
4027               Result          => Result);
4028
4029             --  Skip secondary dispatch table and secondary dispatch table of
4030             --  predefined primitives
4031
4032             Next_Elmt (AI_Tag_Elmt);
4033             Next_Elmt (AI_Tag_Elmt);
4034
4035             Suffix_Index := Suffix_Index + 1;
4036             Next_Elmt (AI_Tag_Comp);
4037          end loop;
4038       end if;
4039
4040       --  Get the _tag entity and the number of primitives of its dispatch
4041       --  table.
4042
4043       DT_Ptr  := Node (First_Elmt (Access_Disp_Table (Typ)));
4044       Nb_Prim := UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ)));
4045
4046       Set_Is_Statically_Allocated (DT,  Is_Library_Level_Tagged_Type (Typ));
4047       Set_Is_Statically_Allocated (SSD, Is_Library_Level_Tagged_Type (Typ));
4048       Set_Is_Statically_Allocated (TSD, Is_Library_Level_Tagged_Type (Typ));
4049       Set_Is_Statically_Allocated (Predef_Prims,
4050         Is_Library_Level_Tagged_Type (Typ));
4051
4052       --  In case of locally defined tagged type we declare the object
4053       --  containing the dispatch table by means of a variable. Its
4054       --  initialization is done later by means of an assignment. This is
4055       --  required to generate its External_Tag.
4056
4057       if not Building_Static_DT (Typ) then
4058
4059          --  Generate:
4060          --    DT     : No_Dispatch_Table_Wrapper;
4061          --    for DT'Alignment use Address'Alignment;
4062          --    DT_Ptr : Tag := !Tag (DT.NDT_Prims_Ptr'Address);
4063
4064          if not Has_DT (Typ) then
4065             Append_To (Result,
4066               Make_Object_Declaration (Loc,
4067                 Defining_Identifier => DT,
4068                 Aliased_Present     => True,
4069                 Constant_Present    => False,
4070                 Object_Definition   =>
4071                   New_Reference_To
4072                     (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
4073
4074             Append_To (Result,
4075               Make_Attribute_Definition_Clause (Loc,
4076                 Name       => New_Reference_To (DT, Loc),
4077                 Chars      => Name_Alignment,
4078                 Expression =>
4079                   Make_Attribute_Reference (Loc,
4080                     Prefix =>
4081                       New_Reference_To (RTE (RE_Integer_Address), Loc),
4082                     Attribute_Name => Name_Alignment)));
4083
4084             Append_To (Result,
4085               Make_Object_Declaration (Loc,
4086                 Defining_Identifier => DT_Ptr,
4087                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
4088                 Constant_Present    => True,
4089                 Expression =>
4090                   Unchecked_Convert_To (RTE (RE_Tag),
4091                     Make_Attribute_Reference (Loc,
4092                       Prefix =>
4093                         Make_Selected_Component (Loc,
4094                           Prefix => New_Reference_To (DT, Loc),
4095                         Selector_Name =>
4096                           New_Occurrence_Of
4097                             (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
4098                       Attribute_Name => Name_Address))));
4099
4100          --  Generate:
4101          --    DT : Dispatch_Table_Wrapper (Nb_Prim);
4102          --    for DT'Alignment use Address'Alignment;
4103          --    DT_Ptr : Tag := !Tag (DT.Prims_Ptr'Address);
4104
4105          else
4106             --  If the tagged type has no primitives we add a dummy slot
4107             --  whose address will be the tag of this type.
4108
4109             if Nb_Prim = 0 then
4110                DT_Constr_List :=
4111                  New_List (Make_Integer_Literal (Loc, 1));
4112             else
4113                DT_Constr_List :=
4114                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
4115             end if;
4116
4117             Append_To (Result,
4118               Make_Object_Declaration (Loc,
4119                 Defining_Identifier => DT,
4120                 Aliased_Present     => True,
4121                 Constant_Present    => False,
4122                 Object_Definition   =>
4123                   Make_Subtype_Indication (Loc,
4124                     Subtype_Mark =>
4125                       New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
4126                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
4127                                     Constraints => DT_Constr_List))));
4128
4129             Append_To (Result,
4130               Make_Attribute_Definition_Clause (Loc,
4131                 Name       => New_Reference_To (DT, Loc),
4132                 Chars      => Name_Alignment,
4133                 Expression =>
4134                   Make_Attribute_Reference (Loc,
4135                     Prefix =>
4136                       New_Reference_To (RTE (RE_Integer_Address), Loc),
4137                     Attribute_Name => Name_Alignment)));
4138
4139             Append_To (Result,
4140               Make_Object_Declaration (Loc,
4141                 Defining_Identifier => DT_Ptr,
4142                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
4143                 Constant_Present    => True,
4144                 Expression =>
4145                   Unchecked_Convert_To (RTE (RE_Tag),
4146                     Make_Attribute_Reference (Loc,
4147                       Prefix =>
4148                         Make_Selected_Component (Loc,
4149                           Prefix => New_Reference_To (DT, Loc),
4150                         Selector_Name =>
4151                           New_Occurrence_Of
4152                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
4153                       Attribute_Name => Name_Address))));
4154
4155             Append_To (Result,
4156               Make_Object_Declaration (Loc,
4157                 Defining_Identifier =>
4158                   Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))),
4159                 Constant_Present    => True,
4160                 Object_Definition   => New_Reference_To
4161                                             (RTE (RE_Address), Loc),
4162                 Expression =>
4163                   Make_Attribute_Reference (Loc,
4164                     Prefix =>
4165                       Make_Selected_Component (Loc,
4166                         Prefix => New_Reference_To (DT, Loc),
4167                       Selector_Name =>
4168                         New_Occurrence_Of
4169                           (RTE_Record_Component (RE_Predef_Prims), Loc)),
4170                     Attribute_Name => Name_Address)));
4171          end if;
4172       end if;
4173
4174       --  Generate: Exname : constant String := full_qualified_name (typ);
4175       --  The type itself may be an anonymous parent type, so use the first
4176       --  subtype to have a user-recognizable name.
4177
4178       Append_To (Result,
4179         Make_Object_Declaration (Loc,
4180           Defining_Identifier => Exname,
4181           Constant_Present    => True,
4182           Object_Definition   => New_Reference_To (Standard_String, Loc),
4183           Expression =>
4184             Make_String_Literal (Loc,
4185               Full_Qualified_Name (First_Subtype (Typ)))));
4186
4187       Set_Is_Statically_Allocated (Exname);
4188       Set_Is_True_Constant (Exname);
4189
4190       --  Declare the object used by Ada.Tags.Register_Tag
4191
4192       if RTE_Available (RE_Register_Tag) then
4193          Append_To (Result,
4194            Make_Object_Declaration (Loc,
4195              Defining_Identifier => HT_Link,
4196              Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc)));
4197       end if;
4198
4199       --  Generate code to create the storage for the type specific data object
4200       --  with enough space to store the tags of the ancestors plus the tags
4201       --  of all the implemented interfaces (as described in a-tags.adb).
4202
4203       --   TSD : Type_Specific_Data (I_Depth) :=
4204       --           (Idepth             => I_Depth,
4205       --            Access_Level       => Type_Access_Level (Typ),
4206       --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
4207       --            External_Tag       => Cstring_Ptr!(Exname'Address))
4208       --            HT_Link            => HT_Link'Address,
4209       --            Transportable      => <<boolean-value>>,
4210       --            RC_Offset          => <<integer-value>>,
4211       --            [ Size_Func         => Size_Prim'Access ]
4212       --            [ Interfaces_Table  => <<access-value>> ]
4213       --            [ SSD               => SSD_Table'Address ]
4214       --            Tags_Table         => (0 => null,
4215       --                                   1 => Parent'Tag
4216       --                                   ...);
4217       --   for TSD'Alignment use Address'Alignment
4218
4219       TSD_Aggr_List := New_List;
4220
4221       --  Idepth: Count ancestors to compute the inheritance depth. For private
4222       --  extensions, always go to the full view in order to compute the real
4223       --  inheritance depth.
4224
4225       declare
4226          Current_Typ : Entity_Id;
4227          Parent_Typ  : Entity_Id;
4228
4229       begin
4230          I_Depth     := 0;
4231          Current_Typ := Typ;
4232          loop
4233             Parent_Typ := Etype (Current_Typ);
4234
4235             if Is_Private_Type (Parent_Typ) then
4236                Parent_Typ := Full_View (Base_Type (Parent_Typ));
4237             end if;
4238
4239             exit when Parent_Typ = Current_Typ;
4240
4241             I_Depth := I_Depth + 1;
4242             Current_Typ := Parent_Typ;
4243          end loop;
4244       end;
4245
4246       Append_To (TSD_Aggr_List,
4247         Make_Integer_Literal (Loc, I_Depth));
4248
4249       --  Access_Level
4250
4251       Append_To (TSD_Aggr_List,
4252         Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
4253
4254       --  Expanded_Name
4255
4256       Append_To (TSD_Aggr_List,
4257         Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4258           Make_Attribute_Reference (Loc,
4259             Prefix => New_Reference_To (Exname, Loc),
4260             Attribute_Name => Name_Address)));
4261
4262       --  External_Tag of a local tagged type
4263
4264       --     <typ>A : constant String :=
4265       --                "Internal tag at 16#tag-addr#: <full-name-of-typ>";
4266
4267       --  The reason we generate this strange name is that we do not want to
4268       --  enter local tagged types in the global hash table used to compute
4269       --  the Internal_Tag attribute for two reasons:
4270
4271       --    1. It is hard to avoid a tasking race condition for entering the
4272       --    entry into the hash table.
4273
4274       --    2. It would cause a storage leak, unless we rig up considerable
4275       --    mechanism to remove the entry from the hash table on exit.
4276
4277       --  So what we do is to generate the above external tag name, where the
4278       --  hex address is the address of the local dispatch table (i.e. exactly
4279       --  the value we want if Internal_Tag is computed from this string).
4280
4281       --  Of course this value will only be valid if the tagged type is still
4282       --  in scope, but it clearly must be erroneous to compute the internal
4283       --  tag of a tagged type that is out of scope!
4284
4285       --  We don't do this processing if an explicit external tag has been
4286       --  specified. That's an odd case for which we have already issued a
4287       --  warning, where we will not be able to compute the internal tag.
4288
4289       if not Is_Library_Level_Entity (Typ)
4290         and then not Has_External_Tag_Rep_Clause (Typ)
4291       then
4292          declare
4293             Exname      : constant Entity_Id :=
4294                             Make_Defining_Identifier (Loc,
4295                               New_External_Name (Tname, 'A'));
4296
4297             Full_Name   : constant String_Id :=
4298                             Full_Qualified_Name (First_Subtype (Typ));
4299             Str1_Id     : String_Id;
4300             Str2_Id     : String_Id;
4301
4302          begin
4303             --  Generate:
4304             --    Str1 = "Internal tag at 16#";
4305
4306             Start_String;
4307             Store_String_Chars ("Internal tag at 16#");
4308             Str1_Id := End_String;
4309
4310             --  Generate:
4311             --    Str2 = "#: <type-full-name>";
4312
4313             Start_String;
4314             Store_String_Chars ("#: ");
4315             Store_String_Chars (Full_Name);
4316             Str2_Id := End_String;
4317
4318             --  Generate:
4319             --    Exname : constant String :=
4320             --               Str1 & Address_Image (Tag) & Str2;
4321
4322             if RTE_Available (RE_Address_Image) then
4323                Append_To (Result,
4324                  Make_Object_Declaration (Loc,
4325                    Defining_Identifier => Exname,
4326                    Constant_Present    => True,
4327                    Object_Definition   => New_Reference_To
4328                                             (Standard_String, Loc),
4329                    Expression =>
4330                      Make_Op_Concat (Loc,
4331                        Left_Opnd =>
4332                          Make_String_Literal (Loc, Str1_Id),
4333                        Right_Opnd =>
4334                          Make_Op_Concat (Loc,
4335                            Left_Opnd =>
4336                              Make_Function_Call (Loc,
4337                                Name =>
4338                                  New_Reference_To
4339                                    (RTE (RE_Address_Image), Loc),
4340                                Parameter_Associations => New_List (
4341                                  Unchecked_Convert_To (RTE (RE_Address),
4342                                    New_Reference_To (DT_Ptr, Loc)))),
4343                            Right_Opnd =>
4344                              Make_String_Literal (Loc, Str2_Id)))));
4345
4346             else
4347                Append_To (Result,
4348                  Make_Object_Declaration (Loc,
4349                    Defining_Identifier => Exname,
4350                    Constant_Present    => True,
4351                    Object_Definition   => New_Reference_To
4352                                             (Standard_String, Loc),
4353                    Expression =>
4354                      Make_Op_Concat (Loc,
4355                        Left_Opnd =>
4356                          Make_String_Literal (Loc, Str1_Id),
4357                        Right_Opnd =>
4358                          Make_String_Literal (Loc, Str2_Id))));
4359             end if;
4360
4361             New_Node :=
4362               Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4363                 Make_Attribute_Reference (Loc,
4364                   Prefix => New_Reference_To (Exname, Loc),
4365                   Attribute_Name => Name_Address));
4366          end;
4367
4368       --  External tag of a library-level tagged type: Check for a definition
4369       --  of External_Tag. The clause is considered only if it applies to this
4370       --  specific tagged type, as opposed to one of its ancestors.
4371       --  If the type is an unconstrained type extension, we are building the
4372       --  dispatch table of its anonymous base type, so the external tag, if
4373       --  any was specified, must be retrieved from the first subtype.
4374
4375       else
4376          declare
4377             Def : constant Node_Id := Get_Attribute_Definition_Clause
4378                                         (First_Subtype (Typ),
4379                                          Attribute_External_Tag);
4380
4381             Old_Val : String_Id;
4382             New_Val : String_Id;
4383             E       : Entity_Id;
4384
4385          begin
4386             if not Present (Def)
4387               or else Entity (Name (Def)) /= First_Subtype (Typ)
4388             then
4389                New_Node :=
4390                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4391                    Make_Attribute_Reference (Loc,
4392                      Prefix         => New_Reference_To (Exname, Loc),
4393                      Attribute_Name => Name_Address));
4394             else
4395                Old_Val := Strval (Expr_Value_S (Expression (Def)));
4396
4397                --  For the rep clause "for <typ>'external_tag use y" generate:
4398
4399                --     <typ>A : constant string := y;
4400                --
4401                --  <typ>A'Address is used to set the External_Tag component
4402                --  of the TSD
4403
4404                --  Create a new nul terminated string if it is not already
4405
4406                if String_Length (Old_Val) > 0
4407                  and then
4408                   Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
4409                then
4410                   New_Val := Old_Val;
4411                else
4412                   Start_String (Old_Val);
4413                   Store_String_Char (Get_Char_Code (ASCII.NUL));
4414                   New_Val := End_String;
4415                end if;
4416
4417                E := Make_Defining_Identifier (Loc,
4418                       New_External_Name (Chars (Typ), 'A'));
4419
4420                Append_To (Result,
4421                  Make_Object_Declaration (Loc,
4422                    Defining_Identifier => E,
4423                    Constant_Present    => True,
4424                    Object_Definition   =>
4425                      New_Reference_To (Standard_String, Loc),
4426                    Expression          =>
4427                      Make_String_Literal (Loc, New_Val)));
4428
4429                New_Node :=
4430                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
4431                    Make_Attribute_Reference (Loc,
4432                      Prefix => New_Reference_To (E, Loc),
4433                      Attribute_Name => Name_Address));
4434             end if;
4435          end;
4436       end if;
4437
4438       Append_To (TSD_Aggr_List, New_Node);
4439
4440       --  HT_Link
4441
4442       if RTE_Available (RE_Register_Tag) then
4443          Append_To (TSD_Aggr_List,
4444            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4445              Make_Attribute_Reference (Loc,
4446                Prefix => New_Reference_To (HT_Link, Loc),
4447                Attribute_Name => Name_Address)));
4448       else
4449          Append_To (TSD_Aggr_List,
4450            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4451              New_Reference_To (RTE (RE_Null_Address), Loc)));
4452       end if;
4453
4454       --  Transportable: Set for types that can be used in remote calls
4455       --  with respect to E.4(18) legality rules.
4456
4457       declare
4458          Transportable : Entity_Id;
4459
4460       begin
4461          Transportable :=
4462            Boolean_Literals
4463              (Is_Pure (Typ)
4464                 or else Is_Shared_Passive (Typ)
4465                 or else
4466                   ((Is_Remote_Types (Typ)
4467                       or else Is_Remote_Call_Interface (Typ))
4468                    and then Original_View_In_Visible_Part (Typ))
4469                 or else not Comes_From_Source (Typ));
4470
4471          Append_To (TSD_Aggr_List,
4472             New_Occurrence_Of (Transportable, Loc));
4473       end;
4474
4475       --  RC_Offset: These are the valid values and their meaning:
4476
4477       --   >0: For simple types with controlled components is
4478       --         type._record_controller'position
4479
4480       --    0: For types with no controlled components
4481
4482       --   -1: For complex types with controlled components where the position
4483       --       of the record controller is not statically computable but there
4484       --       are controlled components at this level. The _Controller field
4485       --       is available right after the _parent.
4486
4487       --   -2: There are no controlled components at this level. We need to
4488       --       get the position from the parent.
4489
4490       declare
4491          RC_Offset_Node : Node_Id;
4492
4493       begin
4494          if not Has_Controlled_Component (Typ) then
4495             RC_Offset_Node := Make_Integer_Literal (Loc, 0);
4496
4497          elsif Etype (Typ) /= Typ
4498            and then Has_Discriminants (Parent_Typ)
4499          then
4500             if Has_New_Controlled_Component (Typ) then
4501                RC_Offset_Node := Make_Integer_Literal (Loc, -1);
4502             else
4503                RC_Offset_Node := Make_Integer_Literal (Loc, -2);
4504             end if;
4505          else
4506             RC_Offset_Node :=
4507               Make_Attribute_Reference (Loc,
4508                 Prefix =>
4509                   Make_Selected_Component (Loc,
4510                     Prefix => New_Reference_To (Typ, Loc),
4511                     Selector_Name =>
4512                       New_Reference_To (Controller_Component (Typ), Loc)),
4513                 Attribute_Name => Name_Position);
4514
4515             --  This is not proper Ada code to use the attribute 'Position
4516             --  on something else than an object but this is supported by
4517             --  the back end (see comment on the Bit_Component attribute in
4518             --  sem_attr). So we avoid semantic checking here.
4519
4520             --  Is this documented in sinfo.ads??? it should be!
4521
4522             Set_Analyzed (RC_Offset_Node);
4523             Set_Etype (Prefix (RC_Offset_Node), RTE (RE_Record_Controller));
4524             Set_Etype (Prefix (Prefix (RC_Offset_Node)), Typ);
4525             Set_Etype (Selector_Name (Prefix (RC_Offset_Node)),
4526               RTE (RE_Record_Controller));
4527             Set_Etype (RC_Offset_Node, RTE (RE_Storage_Offset));
4528          end if;
4529
4530          Append_To (TSD_Aggr_List, RC_Offset_Node);
4531       end;
4532
4533       --  Size_Func
4534
4535       if RTE_Record_Component_Available (RE_Size_Func) then
4536          if not Building_Static_DT (Typ)
4537            or else Is_Interface (Typ)
4538          then
4539             Append_To (TSD_Aggr_List,
4540               Unchecked_Convert_To (RTE (RE_Size_Ptr),
4541                 New_Reference_To (RTE (RE_Null_Address), Loc)));
4542
4543          else
4544             declare
4545                Prim_Elmt : Elmt_Id;
4546                Prim      : Entity_Id;
4547
4548             begin
4549                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4550                while Present (Prim_Elmt) loop
4551                   Prim := Node (Prim_Elmt);
4552
4553                   if Chars (Prim) = Name_uSize then
4554                      while Present (Alias (Prim)) loop
4555                         Prim := Alias (Prim);
4556                      end loop;
4557
4558                      if Is_Abstract_Subprogram (Prim) then
4559                         Append_To (TSD_Aggr_List,
4560                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
4561                             New_Reference_To (RTE (RE_Null_Address), Loc)));
4562                      else
4563                         Append_To (TSD_Aggr_List,
4564                           Unchecked_Convert_To (RTE (RE_Size_Ptr),
4565                             Make_Attribute_Reference (Loc,
4566                               Prefix => New_Reference_To (Prim, Loc),
4567                               Attribute_Name => Name_Unrestricted_Access)));
4568                      end if;
4569
4570                      exit;
4571                   end if;
4572
4573                   Next_Elmt (Prim_Elmt);
4574                end loop;
4575             end;
4576          end if;
4577       end if;
4578
4579       --  Interfaces_Table (required for AI-405)
4580
4581       if RTE_Record_Component_Available (RE_Interfaces_Table) then
4582
4583          --  Count the number of interface types implemented by Typ
4584
4585          Collect_Interfaces (Typ, Typ_Ifaces);
4586
4587          AI := First_Elmt (Typ_Ifaces);
4588          while Present (AI) loop
4589             Num_Ifaces := Num_Ifaces + 1;
4590             Next_Elmt (AI);
4591          end loop;
4592
4593          if Num_Ifaces = 0 then
4594             Iface_Table_Node := Make_Null (Loc);
4595
4596          --  Generate the Interface_Table object
4597
4598          else
4599             declare
4600                TSD_Ifaces_List : constant List_Id := New_List;
4601                Elmt       : Elmt_Id;
4602                Sec_DT_Tag : Node_Id;
4603
4604             begin
4605                AI := First_Elmt (Typ_Ifaces);
4606                while Present (AI) loop
4607                   if Is_Ancestor (Node (AI), Typ) then
4608                      Sec_DT_Tag :=
4609                        New_Reference_To (DT_Ptr, Loc);
4610                   else
4611                      Elmt :=
4612                        Next_Elmt
4613                         (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
4614                      pragma Assert (Has_Thunks (Node (Elmt)));
4615
4616                      while Ekind (Node (Elmt)) = E_Constant
4617                         and then not
4618                           Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
4619                      loop
4620                         pragma Assert (Has_Thunks (Node (Elmt)));
4621                         Next_Elmt (Elmt);
4622                         pragma Assert (Has_Thunks (Node (Elmt)));
4623                         Next_Elmt (Elmt);
4624                         pragma Assert (not Has_Thunks (Node (Elmt)));
4625                         Next_Elmt (Elmt);
4626                         pragma Assert (not Has_Thunks (Node (Elmt)));
4627                         Next_Elmt (Elmt);
4628                      end loop;
4629
4630                      pragma Assert (Ekind (Node (Elmt)) = E_Constant
4631                        and then not
4632                          Has_Thunks (Node (Next_Elmt (Next_Elmt (Elmt)))));
4633                      Sec_DT_Tag :=
4634                        New_Reference_To (Node (Next_Elmt (Next_Elmt (Elmt))),
4635                                          Loc);
4636                   end if;
4637
4638                   Append_To (TSD_Ifaces_List,
4639                      Make_Aggregate (Loc,
4640                        Expressions => New_List (
4641
4642                         --  Iface_Tag
4643
4644                         Unchecked_Convert_To (RTE (RE_Tag),
4645                           New_Reference_To
4646                             (Node (First_Elmt (Access_Disp_Table (Node (AI)))),
4647                              Loc)),
4648
4649                         --  Static_Offset_To_Top
4650
4651                         New_Reference_To (Standard_True, Loc),
4652
4653                         --  Offset_To_Top_Value
4654
4655                         Make_Integer_Literal (Loc, 0),
4656
4657                         --  Offset_To_Top_Func
4658
4659                         Make_Null (Loc),
4660
4661                         --  Secondary_DT
4662
4663                         Unchecked_Convert_To (RTE (RE_Tag), Sec_DT_Tag)
4664
4665                         )));
4666
4667                   Next_Elmt (AI);
4668                end loop;
4669
4670                Name_ITable := New_External_Name (Tname, 'I');
4671                ITable      := Make_Defining_Identifier (Loc, Name_ITable);
4672                Set_Is_Statically_Allocated (ITable,
4673                  Is_Library_Level_Tagged_Type (Typ));
4674
4675                --  The table of interfaces is not constant; its slots are
4676                --  filled at run-time by the IP routine using attribute
4677                --  'Position to know the location of the tag components
4678                --  (and this attribute cannot be safely used before the
4679                --  object is initialized).
4680
4681                Append_To (Result,
4682                  Make_Object_Declaration (Loc,
4683                    Defining_Identifier => ITable,
4684                    Aliased_Present     => True,
4685                    Constant_Present    => False,
4686                    Object_Definition   =>
4687                      Make_Subtype_Indication (Loc,
4688                        Subtype_Mark =>
4689                          New_Reference_To (RTE (RE_Interface_Data), Loc),
4690                        Constraint => Make_Index_Or_Discriminant_Constraint
4691                          (Loc,
4692                           Constraints => New_List (
4693                             Make_Integer_Literal (Loc, Num_Ifaces)))),
4694
4695                    Expression => Make_Aggregate (Loc,
4696                      Expressions => New_List (
4697                        Make_Integer_Literal (Loc, Num_Ifaces),
4698                        Make_Aggregate (Loc,
4699                          Expressions => TSD_Ifaces_List)))));
4700
4701                Append_To (Result,
4702                  Make_Attribute_Definition_Clause (Loc,
4703                    Name       => New_Reference_To (ITable, Loc),
4704                    Chars      => Name_Alignment,
4705                    Expression =>
4706                      Make_Attribute_Reference (Loc,
4707                        Prefix =>
4708                          New_Reference_To (RTE (RE_Integer_Address), Loc),
4709                        Attribute_Name => Name_Alignment)));
4710
4711                Iface_Table_Node :=
4712                  Make_Attribute_Reference (Loc,
4713                    Prefix         => New_Reference_To (ITable, Loc),
4714                    Attribute_Name => Name_Unchecked_Access);
4715             end;
4716          end if;
4717
4718          Append_To (TSD_Aggr_List, Iface_Table_Node);
4719       end if;
4720
4721       --  Generate the Select Specific Data table for synchronized types that
4722       --  implement synchronized interfaces. The size of the table is
4723       --  constrained by the number of non-predefined primitive operations.
4724
4725       if RTE_Record_Component_Available (RE_SSD) then
4726          if Ada_Version >= Ada_05
4727            and then Has_DT (Typ)
4728            and then Is_Concurrent_Record_Type (Typ)
4729            and then Has_Interfaces (Typ)
4730            and then Nb_Prim > 0
4731            and then not Is_Abstract_Type (Typ)
4732            and then not Is_Controlled (Typ)
4733            and then not Restriction_Active (No_Dispatching_Calls)
4734          then
4735             Append_To (Result,
4736               Make_Object_Declaration (Loc,
4737                 Defining_Identifier => SSD,
4738                 Aliased_Present     => True,
4739                 Object_Definition   =>
4740                   Make_Subtype_Indication (Loc,
4741                     Subtype_Mark => New_Reference_To (
4742                       RTE (RE_Select_Specific_Data), Loc),
4743                     Constraint   =>
4744                       Make_Index_Or_Discriminant_Constraint (Loc,
4745                         Constraints => New_List (
4746                           Make_Integer_Literal (Loc, Nb_Prim))))));
4747
4748             Append_To (Result,
4749               Make_Attribute_Definition_Clause (Loc,
4750                 Name       => New_Reference_To (SSD, Loc),
4751                 Chars      => Name_Alignment,
4752                 Expression =>
4753                   Make_Attribute_Reference (Loc,
4754                     Prefix =>
4755                       New_Reference_To (RTE (RE_Integer_Address), Loc),
4756                     Attribute_Name => Name_Alignment)));
4757
4758             --  This table is initialized by Make_Select_Specific_Data_Table,
4759             --  which calls Set_Entry_Index and Set_Prim_Op_Kind.
4760
4761             Append_To (TSD_Aggr_List,
4762               Make_Attribute_Reference (Loc,
4763                 Prefix => New_Reference_To (SSD, Loc),
4764                 Attribute_Name => Name_Unchecked_Access));
4765          else
4766             Append_To (TSD_Aggr_List, Make_Null (Loc));
4767          end if;
4768       end if;
4769
4770       --  Initialize the table of ancestor tags. In case of interface types
4771       --  this table is not needed.
4772
4773       TSD_Tags_List := New_List;
4774
4775       --  If we are not statically allocating the dispatch table then we must
4776       --  fill position 0 with null because we still have not generated the
4777       --  tag of Typ.
4778
4779       if not Building_Static_DT (Typ)
4780         or else Is_Interface (Typ)
4781       then
4782          Append_To (TSD_Tags_List,
4783            Unchecked_Convert_To (RTE (RE_Tag),
4784              New_Reference_To (RTE (RE_Null_Address), Loc)));
4785
4786       --  Otherwise we can safely reference the tag
4787
4788       else
4789          Append_To (TSD_Tags_List,
4790            New_Reference_To (DT_Ptr, Loc));
4791       end if;
4792
4793       --  Fill the rest of the table with the tags of the ancestors
4794
4795       declare
4796          Current_Typ : Entity_Id;
4797          Parent_Typ  : Entity_Id;
4798          Pos         : Nat;
4799
4800       begin
4801          Pos := 1;
4802          Current_Typ := Typ;
4803
4804          loop
4805             Parent_Typ := Etype (Current_Typ);
4806
4807             if Is_Private_Type (Parent_Typ) then
4808                Parent_Typ := Full_View (Base_Type (Parent_Typ));
4809             end if;
4810
4811             exit when Parent_Typ = Current_Typ;
4812
4813             if Is_CPP_Class (Parent_Typ)
4814               or else Is_Interface (Typ)
4815             then
4816                --  The tags defined in the C++ side will be inherited when
4817                --  the object is constructed (Exp_Ch3.Build_Init_Procedure)
4818
4819                Append_To (TSD_Tags_List,
4820                  Unchecked_Convert_To (RTE (RE_Tag),
4821                    New_Reference_To (RTE (RE_Null_Address), Loc)));
4822             else
4823                Append_To (TSD_Tags_List,
4824                  New_Reference_To
4825                    (Node (First_Elmt (Access_Disp_Table (Parent_Typ))),
4826                     Loc));
4827             end if;
4828
4829             Pos := Pos + 1;
4830             Current_Typ := Parent_Typ;
4831          end loop;
4832
4833          pragma Assert (Pos = I_Depth + 1);
4834       end;
4835
4836       Append_To (TSD_Aggr_List,
4837         Make_Aggregate (Loc,
4838           Expressions => TSD_Tags_List));
4839
4840       --  Build the TSD object
4841
4842       Append_To (Result,
4843         Make_Object_Declaration (Loc,
4844           Defining_Identifier => TSD,
4845           Aliased_Present     => True,
4846           Constant_Present    => Building_Static_DT (Typ),
4847           Object_Definition   =>
4848             Make_Subtype_Indication (Loc,
4849               Subtype_Mark => New_Reference_To (
4850                 RTE (RE_Type_Specific_Data), Loc),
4851               Constraint =>
4852                 Make_Index_Or_Discriminant_Constraint (Loc,
4853                   Constraints => New_List (
4854                     Make_Integer_Literal (Loc, I_Depth)))),
4855
4856           Expression => Make_Aggregate (Loc,
4857             Expressions => TSD_Aggr_List)));
4858
4859       Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
4860
4861       Append_To (Result,
4862         Make_Attribute_Definition_Clause (Loc,
4863           Name       => New_Reference_To (TSD, Loc),
4864           Chars      => Name_Alignment,
4865           Expression =>
4866             Make_Attribute_Reference (Loc,
4867               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
4868               Attribute_Name => Name_Alignment)));
4869
4870       --  Initialize or declare the dispatch table object
4871
4872       if not Has_DT (Typ) then
4873          DT_Constr_List := New_List;
4874          DT_Aggr_List   := New_List;
4875
4876          --  Typeinfo
4877
4878          New_Node :=
4879            Make_Attribute_Reference (Loc,
4880              Prefix => New_Reference_To (TSD, Loc),
4881              Attribute_Name => Name_Address);
4882
4883          Append_To (DT_Constr_List, New_Node);
4884          Append_To (DT_Aggr_List,   New_Copy (New_Node));
4885          Append_To (DT_Aggr_List,   Make_Integer_Literal (Loc, 0));
4886
4887          --  In case of locally defined tagged types we have already declared
4888          --  and uninitialized object for the dispatch table, which is now
4889          --  initialized by means of the following assignment:
4890
4891          --    DT := (TSD'Address, 0);
4892
4893          if not Building_Static_DT (Typ) then
4894             Append_To (Result,
4895               Make_Assignment_Statement (Loc,
4896                 Name => New_Reference_To (DT, Loc),
4897                 Expression => Make_Aggregate (Loc,
4898                   Expressions => DT_Aggr_List)));
4899
4900          --  In case of library level tagged types we declare and export now
4901          --  the constant object containing the dummy dispatch table. There
4902          --  is no need to declare the tag here because it has been previously
4903          --  declared by Make_Tags
4904
4905          --   DT : aliased constant No_Dispatch_Table :=
4906          --          (NDT_TSD       => TSD'Address;
4907          --           NDT_Prims_Ptr => 0);
4908          --   for DT'Alignment use Address'Alignment;
4909
4910          else
4911             Append_To (Result,
4912               Make_Object_Declaration (Loc,
4913                 Defining_Identifier => DT,
4914                 Aliased_Present     => True,
4915                 Constant_Present    => True,
4916                 Object_Definition   =>
4917                   New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc),
4918                 Expression => Make_Aggregate (Loc,
4919                   Expressions => DT_Aggr_List)));
4920
4921             Append_To (Result,
4922               Make_Attribute_Definition_Clause (Loc,
4923                 Name       => New_Reference_To (DT, Loc),
4924                 Chars      => Name_Alignment,
4925                 Expression =>
4926                   Make_Attribute_Reference (Loc,
4927                     Prefix =>
4928                       New_Reference_To (RTE (RE_Integer_Address), Loc),
4929                     Attribute_Name => Name_Alignment)));
4930
4931             Export_DT (Typ, DT);
4932          end if;
4933
4934       --  Common case: Typ has a dispatch table
4935
4936       --  Generate:
4937
4938       --   Predef_Prims : Address_Array (1 .. Default_Prim_Ops_Count) :=
4939       --                    (predef-prim-op-1'address,
4940       --                     predef-prim-op-2'address,
4941       --                     ...
4942       --                     predef-prim-op-n'address);
4943       --   for Predef_Prims'Alignment use Address'Alignment
4944
4945       --   DT : Dispatch_Table (Nb_Prims) :=
4946       --          (Signature => <sig-value>,
4947       --           Tag_Kind  => <tag_kind-value>,
4948       --           Predef_Prims => Predef_Prims'First'Address,
4949       --           Offset_To_Top => 0,
4950       --           TSD           => TSD'Address;
4951       --           Prims_Ptr     => (prim-op-1'address,
4952       --                             prim-op-2'address,
4953       --                             ...
4954       --                             prim-op-n'address));
4955       --   for DT'Alignment use Address'Alignment
4956
4957       else
4958          declare
4959             Pos : Nat;
4960
4961          begin
4962             if not Building_Static_DT (Typ) then
4963                Nb_Predef_Prims := Max_Predef_Prims;
4964
4965             else
4966                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
4967                while Present (Prim_Elmt) loop
4968                   Prim := Node (Prim_Elmt);
4969
4970                   if Is_Predefined_Dispatching_Operation (Prim)
4971                     and then not Is_Abstract_Subprogram (Prim)
4972                   then
4973                      Pos := UI_To_Int (DT_Position (Prim));
4974
4975                      if Pos > Nb_Predef_Prims then
4976                         Nb_Predef_Prims := Pos;
4977                      end if;
4978                   end if;
4979
4980                   Next_Elmt (Prim_Elmt);
4981                end loop;
4982             end if;
4983
4984             declare
4985                Prim_Table : array
4986                               (Nat range 1 .. Nb_Predef_Prims) of Entity_Id;
4987                Decl       : Node_Id;
4988                E          : Entity_Id;
4989
4990             begin
4991                Prim_Ops_Aggr_List := New_List;
4992
4993                Prim_Table := (others => Empty);
4994
4995                if Building_Static_DT (Typ) then
4996                   Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
4997                   while Present (Prim_Elmt) loop
4998                      Prim := Node (Prim_Elmt);
4999
5000                      if Is_Predefined_Dispatching_Operation (Prim)
5001                        and then not Is_Abstract_Subprogram (Prim)
5002                        and then not Present (Prim_Table
5003                                               (UI_To_Int (DT_Position (Prim))))
5004                      then
5005                         E := Prim;
5006                         while Present (Alias (E)) loop
5007                            E := Alias (E);
5008                         end loop;
5009
5010                         pragma Assert (not Is_Abstract_Subprogram (E));
5011                         Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5012                      end if;
5013
5014                      Next_Elmt (Prim_Elmt);
5015                   end loop;
5016                end if;
5017
5018                for J in Prim_Table'Range loop
5019                   if Present (Prim_Table (J)) then
5020                      New_Node :=
5021                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5022                          Make_Attribute_Reference (Loc,
5023                            Prefix => New_Reference_To (Prim_Table (J), Loc),
5024                            Attribute_Name => Name_Unrestricted_Access));
5025                   else
5026                      New_Node := Make_Null (Loc);
5027                   end if;
5028
5029                   Append_To (Prim_Ops_Aggr_List, New_Node);
5030                end loop;
5031
5032                New_Node :=
5033                  Make_Aggregate (Loc,
5034                    Expressions => Prim_Ops_Aggr_List);
5035
5036                Decl :=
5037                  Make_Subtype_Declaration (Loc,
5038                    Defining_Identifier =>
5039                      Make_Defining_Identifier (Loc,
5040                        New_Internal_Name ('S')),
5041                    Subtype_Indication =>
5042                      New_Reference_To (RTE (RE_Address_Array), Loc));
5043
5044                Append_To (Result, Decl);
5045
5046                Append_To (Result,
5047                  Make_Object_Declaration (Loc,
5048                    Defining_Identifier => Predef_Prims,
5049                    Aliased_Present     => True,
5050                    Constant_Present    => Building_Static_DT (Typ),
5051                    Object_Definition   => New_Reference_To
5052                                            (Defining_Identifier (Decl), Loc),
5053                    Expression => New_Node));
5054
5055                --  Remember aggregates initializing dispatch tables
5056
5057                Append_Elmt (New_Node, DT_Aggr);
5058
5059                Append_To (Result,
5060                  Make_Attribute_Definition_Clause (Loc,
5061                    Name       => New_Reference_To (Predef_Prims, Loc),
5062                    Chars      => Name_Alignment,
5063                    Expression =>
5064                      Make_Attribute_Reference (Loc,
5065                        Prefix =>
5066                          New_Reference_To (RTE (RE_Integer_Address), Loc),
5067                        Attribute_Name => Name_Alignment)));
5068             end;
5069          end;
5070
5071          --  Stage 1: Initialize the discriminant and the record components
5072
5073          DT_Constr_List := New_List;
5074          DT_Aggr_List   := New_List;
5075
5076          --  Num_Prims. If the tagged type has no primitives we add a dummy
5077          --  slot whose address will be the tag of this type.
5078
5079          if Nb_Prim = 0 then
5080             New_Node := Make_Integer_Literal (Loc, 1);
5081          else
5082             New_Node := Make_Integer_Literal (Loc, Nb_Prim);
5083          end if;
5084
5085          Append_To (DT_Constr_List, New_Node);
5086          Append_To (DT_Aggr_List,   New_Copy (New_Node));
5087
5088          --  Signature
5089
5090          if RTE_Record_Component_Available (RE_Signature) then
5091             Append_To (DT_Aggr_List,
5092               New_Reference_To (RTE (RE_Primary_DT), Loc));
5093          end if;
5094
5095          --  Tag_Kind
5096
5097          if RTE_Record_Component_Available (RE_Tag_Kind) then
5098             Append_To (DT_Aggr_List, Tagged_Kind (Typ));
5099          end if;
5100
5101          --  Predef_Prims
5102
5103          Append_To (DT_Aggr_List,
5104            Make_Attribute_Reference (Loc,
5105              Prefix => New_Reference_To (Predef_Prims, Loc),
5106              Attribute_Name => Name_Address));
5107
5108          --  Offset_To_Top
5109
5110          Append_To (DT_Aggr_List, Make_Integer_Literal (Loc, 0));
5111
5112          --  Typeinfo
5113
5114          Append_To (DT_Aggr_List,
5115            Make_Attribute_Reference (Loc,
5116              Prefix => New_Reference_To (TSD, Loc),
5117              Attribute_Name => Name_Address));
5118
5119          --  Stage 2: Initialize the table of primitive operations
5120
5121          Prim_Ops_Aggr_List := New_List;
5122
5123          if Nb_Prim = 0 then
5124             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5125
5126          elsif not Building_Static_DT (Typ) then
5127             for J in 1 .. Nb_Prim loop
5128                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
5129             end loop;
5130
5131          else
5132             declare
5133                Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
5134                E          : Entity_Id;
5135                Prim       : Entity_Id;
5136                Prim_Elmt  : Elmt_Id;
5137
5138             begin
5139                Prim_Table := (others => Empty);
5140
5141                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5142                while Present (Prim_Elmt) loop
5143                   Prim := Node (Prim_Elmt);
5144
5145                   if Is_Imported (Prim)
5146                     or else Present (Interface_Alias (Prim))
5147                     or else Is_Predefined_Dispatching_Operation (Prim)
5148                   then
5149                      null;
5150
5151                   else
5152                      --  Traverse the list of aliased entities to handle
5153                      --  renamings of predefined primitives.
5154
5155                      E := Prim;
5156                      while Present (Alias (E)) loop
5157                         E := Alias (E);
5158                      end loop;
5159
5160                      if not Is_Predefined_Dispatching_Operation (E)
5161                        and then not Is_Abstract_Subprogram (E)
5162                        and then not Present (Interface_Alias (E))
5163                      then
5164                         pragma Assert
5165                           (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
5166
5167                         Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
5168                      end if;
5169                   end if;
5170
5171                   Next_Elmt (Prim_Elmt);
5172                end loop;
5173
5174                for J in Prim_Table'Range loop
5175                   if Present (Prim_Table (J)) then
5176                      New_Node :=
5177                        Unchecked_Convert_To (RTE (RE_Prim_Ptr),
5178                          Make_Attribute_Reference (Loc,
5179                            Prefix => New_Reference_To (Prim_Table (J), Loc),
5180                            Attribute_Name => Name_Unrestricted_Access));
5181                   else
5182                      New_Node := Make_Null (Loc);
5183                   end if;
5184
5185                   Append_To (Prim_Ops_Aggr_List, New_Node);
5186                end loop;
5187             end;
5188          end if;
5189
5190          New_Node :=
5191            Make_Aggregate (Loc,
5192              Expressions => Prim_Ops_Aggr_List);
5193
5194          Append_To (DT_Aggr_List, New_Node);
5195
5196          --  Remember aggregates initializing dispatch tables
5197
5198          Append_Elmt (New_Node, DT_Aggr);
5199
5200          --  In case of locally defined tagged types we have already declared
5201          --  and uninitialized object for the dispatch table, which is now
5202          --  initialized by means of an assignment.
5203
5204          if not Building_Static_DT (Typ) then
5205             Append_To (Result,
5206               Make_Assignment_Statement (Loc,
5207                 Name => New_Reference_To (DT, Loc),
5208                 Expression => Make_Aggregate (Loc,
5209                   Expressions => DT_Aggr_List)));
5210
5211          --  In case of library level tagged types we declare now and export
5212          --  the constant object containing the dispatch table.
5213
5214          else
5215             Append_To (Result,
5216               Make_Object_Declaration (Loc,
5217                 Defining_Identifier => DT,
5218                 Aliased_Present     => True,
5219                 Constant_Present    => True,
5220                 Object_Definition   =>
5221                   Make_Subtype_Indication (Loc,
5222                     Subtype_Mark => New_Reference_To
5223                                       (RTE (RE_Dispatch_Table_Wrapper), Loc),
5224                     Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
5225                                       Constraints => DT_Constr_List)),
5226                 Expression => Make_Aggregate (Loc,
5227                   Expressions => DT_Aggr_List)));
5228
5229             Append_To (Result,
5230               Make_Attribute_Definition_Clause (Loc,
5231                 Name       => New_Reference_To (DT, Loc),
5232                 Chars      => Name_Alignment,
5233                 Expression =>
5234                   Make_Attribute_Reference (Loc,
5235                     Prefix =>
5236                       New_Reference_To (RTE (RE_Integer_Address), Loc),
5237                     Attribute_Name => Name_Alignment)));
5238
5239             Export_DT (Typ, DT);
5240          end if;
5241       end if;
5242
5243       --  Initialize the table of ancestor tags if not building static
5244       --  dispatch table
5245
5246       if not Building_Static_DT (Typ)
5247         and then not Is_Interface (Typ)
5248         and then not Is_CPP_Class (Typ)
5249       then
5250          Append_To (Result,
5251            Make_Assignment_Statement (Loc,
5252              Name =>
5253                Make_Indexed_Component (Loc,
5254                  Prefix =>
5255                    Make_Selected_Component (Loc,
5256                      Prefix =>
5257                        New_Reference_To (TSD, Loc),
5258                      Selector_Name =>
5259                        New_Reference_To
5260                          (RTE_Record_Component (RE_Tags_Table), Loc)),
5261                  Expressions =>
5262                     New_List (Make_Integer_Literal (Loc, 0))),
5263
5264              Expression =>
5265                New_Reference_To
5266                  (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
5267       end if;
5268
5269       --  Inherit the dispatch tables of the parent. There is no need to
5270       --  inherit anything from the parent when building static dispatch tables
5271       --  because the whole dispatch table (including inherited primitives) has
5272       --  been already built.
5273
5274       if Building_Static_DT (Typ) then
5275          null;
5276
5277       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
5278       --  in the init proc, and we don't need to fill them in here.
5279
5280       elsif Is_CPP_Class (Parent_Typ) then
5281          null;
5282
5283       --  Otherwise we fill in the dispatch tables here
5284
5285       else
5286          if Typ /= Parent_Typ
5287            and then not Is_Interface (Typ)
5288            and then not Restriction_Active (No_Dispatching_Calls)
5289          then
5290             --  Inherit the dispatch table
5291
5292             if not Is_Interface (Typ)
5293               and then not Is_Interface (Parent_Typ)
5294               and then not Is_CPP_Class (Parent_Typ)
5295             then
5296                declare
5297                   Nb_Prims : constant Int :=
5298                                UI_To_Int (DT_Entry_Count
5299                                  (First_Tag_Component (Parent_Typ)));
5300
5301                begin
5302                   Append_To (Elab_Code,
5303                     Build_Inherit_Predefined_Prims (Loc,
5304                       Old_Tag_Node =>
5305                         New_Reference_To
5306                           (Node
5307                            (Next_Elmt
5308                             (First_Elmt
5309                              (Access_Disp_Table (Parent_Typ)))), Loc),
5310                       New_Tag_Node =>
5311                         New_Reference_To
5312                           (Node
5313                            (Next_Elmt
5314                             (First_Elmt
5315                              (Access_Disp_Table (Typ)))), Loc)));
5316
5317                   if Nb_Prims /= 0 then
5318                      Append_To (Elab_Code,
5319                        Build_Inherit_Prims (Loc,
5320                          Typ          => Typ,
5321                          Old_Tag_Node =>
5322                            New_Reference_To
5323                              (Node
5324                               (First_Elmt
5325                                (Access_Disp_Table (Parent_Typ))), Loc),
5326                          New_Tag_Node => New_Reference_To (DT_Ptr, Loc),
5327                          Num_Prims    => Nb_Prims));
5328                   end if;
5329                end;
5330             end if;
5331
5332             --  Inherit the secondary dispatch tables of the ancestor
5333
5334             if not Is_CPP_Class (Parent_Typ) then
5335                declare
5336                   Sec_DT_Ancestor : Elmt_Id :=
5337                                       Next_Elmt
5338                                        (Next_Elmt
5339                                         (First_Elmt
5340                                           (Access_Disp_Table (Parent_Typ))));
5341                   Sec_DT_Typ      : Elmt_Id :=
5342                                       Next_Elmt
5343                                        (Next_Elmt
5344                                          (First_Elmt
5345                                            (Access_Disp_Table (Typ))));
5346
5347                   procedure Copy_Secondary_DTs (Typ : Entity_Id);
5348                   --  Local procedure required to climb through the ancestors
5349                   --  and copy the contents of all their secondary dispatch
5350                   --  tables.
5351
5352                   ------------------------
5353                   -- Copy_Secondary_DTs --
5354                   ------------------------
5355
5356                   procedure Copy_Secondary_DTs (Typ : Entity_Id) is
5357                      E     : Entity_Id;
5358                      Iface : Elmt_Id;
5359
5360                   begin
5361                      --  Climb to the ancestor (if any) handling private types
5362
5363                      if Present (Full_View (Etype (Typ))) then
5364                         if Full_View (Etype (Typ)) /= Typ then
5365                            Copy_Secondary_DTs (Full_View (Etype (Typ)));
5366                         end if;
5367
5368                      elsif Etype (Typ) /= Typ then
5369                         Copy_Secondary_DTs (Etype (Typ));
5370                      end if;
5371
5372                      if Present (Interfaces (Typ))
5373                        and then not Is_Empty_Elmt_List (Interfaces (Typ))
5374                      then
5375                         Iface := First_Elmt (Interfaces (Typ));
5376                         E     := First_Entity (Typ);
5377                         while Present (E)
5378                           and then Present (Node (Sec_DT_Ancestor))
5379                           and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
5380                         loop
5381                            if Is_Tag (E) and then Chars (E) /= Name_uTag then
5382                               declare
5383                                  Num_Prims : constant Int :=
5384                                                UI_To_Int (DT_Entry_Count (E));
5385
5386                               begin
5387                                  if not Is_Interface (Etype (Typ)) then
5388
5389                                     --  Inherit first secondary dispatch table
5390
5391                                     Append_To (Elab_Code,
5392                                       Build_Inherit_Predefined_Prims (Loc,
5393                                         Old_Tag_Node =>
5394                                           Unchecked_Convert_To (RTE (RE_Tag),
5395                                             New_Reference_To
5396                                               (Node
5397                                                 (Next_Elmt (Sec_DT_Ancestor)),
5398                                                Loc)),
5399                                         New_Tag_Node =>
5400                                           Unchecked_Convert_To (RTE (RE_Tag),
5401                                             New_Reference_To
5402                                               (Node (Next_Elmt (Sec_DT_Typ)),
5403                                                Loc))));
5404
5405                                     if Num_Prims /= 0 then
5406                                        Append_To (Elab_Code,
5407                                          Build_Inherit_Prims (Loc,
5408                                            Typ          => Node (Iface),
5409                                            Old_Tag_Node =>
5410                                              Unchecked_Convert_To
5411                                                (RTE (RE_Tag),
5412                                                 New_Reference_To
5413                                                   (Node (Sec_DT_Ancestor),
5414                                                    Loc)),
5415                                            New_Tag_Node =>
5416                                              Unchecked_Convert_To
5417                                               (RTE (RE_Tag),
5418                                                New_Reference_To
5419                                                  (Node (Sec_DT_Typ), Loc)),
5420                                            Num_Prims    => Num_Prims));
5421                                     end if;
5422                                  end if;
5423
5424                                  Next_Elmt (Sec_DT_Ancestor);
5425                                  Next_Elmt (Sec_DT_Typ);
5426
5427                                  --  Skip the secondary dispatch table of
5428                                  --  predefined primitives
5429
5430                                  Next_Elmt (Sec_DT_Ancestor);
5431                                  Next_Elmt (Sec_DT_Typ);
5432
5433                                  if not Is_Interface (Etype (Typ)) then
5434
5435                                     --  Inherit second secondary dispatch table
5436
5437                                     Append_To (Elab_Code,
5438                                       Build_Inherit_Predefined_Prims (Loc,
5439                                         Old_Tag_Node =>
5440                                           Unchecked_Convert_To (RTE (RE_Tag),
5441                                              New_Reference_To
5442                                                (Node
5443                                                  (Next_Elmt (Sec_DT_Ancestor)),
5444                                                 Loc)),
5445                                         New_Tag_Node =>
5446                                           Unchecked_Convert_To (RTE (RE_Tag),
5447                                             New_Reference_To
5448                                               (Node (Next_Elmt (Sec_DT_Typ)),
5449                                                Loc))));
5450
5451                                     if Num_Prims /= 0 then
5452                                        Append_To (Elab_Code,
5453                                          Build_Inherit_Prims (Loc,
5454                                            Typ          => Node (Iface),
5455                                            Old_Tag_Node =>
5456                                              Unchecked_Convert_To
5457                                                (RTE (RE_Tag),
5458                                                 New_Reference_To
5459                                                   (Node (Sec_DT_Ancestor),
5460                                                    Loc)),
5461                                            New_Tag_Node =>
5462                                              Unchecked_Convert_To
5463                                               (RTE (RE_Tag),
5464                                                New_Reference_To
5465                                                  (Node (Sec_DT_Typ), Loc)),
5466                                            Num_Prims    => Num_Prims));
5467                                     end if;
5468                                  end if;
5469                               end;
5470
5471                               Next_Elmt (Sec_DT_Ancestor);
5472                               Next_Elmt (Sec_DT_Typ);
5473
5474                               --  Skip the secondary dispatch table of
5475                               --  predefined primitives
5476
5477                               Next_Elmt (Sec_DT_Ancestor);
5478                               Next_Elmt (Sec_DT_Typ);
5479
5480                               Next_Elmt (Iface);
5481                            end if;
5482
5483                            Next_Entity (E);
5484                         end loop;
5485                      end if;
5486                   end Copy_Secondary_DTs;
5487
5488                begin
5489                   if Present (Node (Sec_DT_Ancestor))
5490                     and then Ekind (Node (Sec_DT_Ancestor)) = E_Constant
5491                   then
5492                      --  Handle private types
5493
5494                      if Present (Full_View (Typ)) then
5495                         Copy_Secondary_DTs (Full_View (Typ));
5496                      else
5497                         Copy_Secondary_DTs (Typ);
5498                      end if;
5499                   end if;
5500                end;
5501             end if;
5502          end if;
5503       end if;
5504
5505       --  Generate code to register the Tag in the External_Tag hash table for
5506       --  the pure Ada type only.
5507
5508       --        Register_Tag (Dt_Ptr);
5509
5510       --  Skip this action in the following cases:
5511       --    1) if Register_Tag is not available.
5512       --    2) in No_Run_Time mode.
5513       --    3) if Typ is not defined at the library level (this is required
5514       --       to avoid adding concurrency control to the hash table used
5515       --       by the run-time to register the tags).
5516
5517       if not No_Run_Time_Mode
5518         and then Is_Library_Level_Entity (Typ)
5519         and then RTE_Available (RE_Register_Tag)
5520       then
5521          Append_To (Elab_Code,
5522            Make_Procedure_Call_Statement (Loc,
5523              Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
5524              Parameter_Associations =>
5525                New_List (New_Reference_To (DT_Ptr, Loc))));
5526       end if;
5527
5528       if not Is_Empty_List (Elab_Code) then
5529          Append_List_To (Result, Elab_Code);
5530       end if;
5531
5532       --  Populate the two auxiliary tables used for dispatching
5533       --  asynchronous, conditional and timed selects for synchronized
5534       --  types that implement a limited interface.
5535
5536       if Ada_Version >= Ada_05
5537         and then Is_Concurrent_Record_Type (Typ)
5538         and then Has_Interfaces (Typ)
5539       then
5540          Append_List_To (Result,
5541            Make_Select_Specific_Data_Table (Typ));
5542       end if;
5543
5544       --  Remember entities containing dispatch tables
5545
5546       Append_Elmt (Predef_Prims, DT_Decl);
5547       Append_Elmt (DT, DT_Decl);
5548
5549       Analyze_List (Result, Suppress => All_Checks);
5550       Set_Has_Dispatch_Table (Typ);
5551
5552       --  Mark entities containing dispatch tables. Required by the backend to
5553       --  handle them properly.
5554
5555       if not Is_Interface (Typ) then
5556          declare
5557             Elmt : Elmt_Id;
5558
5559          begin
5560             --  Ensure that entities Prim_Ptr and Predef_Prims_Table_Ptr have
5561             --  the decoration required by the backend
5562
5563             Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr));
5564             Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr));
5565
5566             --  Object declarations
5567
5568             Elmt := First_Elmt (DT_Decl);
5569             while Present (Elmt) loop
5570                Set_Is_Dispatch_Table_Entity (Node (Elmt));
5571                pragma Assert (Ekind (Etype (Node (Elmt))) = E_Array_Subtype
5572                  or else Ekind (Etype (Node (Elmt))) = E_Record_Subtype);
5573                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
5574                Next_Elmt (Elmt);
5575             end loop;
5576
5577             --  Aggregates initializing dispatch tables
5578
5579             Elmt := First_Elmt (DT_Aggr);
5580             while Present (Elmt) loop
5581                Set_Is_Dispatch_Table_Entity (Etype (Node (Elmt)));
5582                Next_Elmt (Elmt);
5583             end loop;
5584          end;
5585       end if;
5586
5587       return Result;
5588    end Make_DT;
5589
5590    -------------------------------------
5591    -- Make_Select_Specific_Data_Table --
5592    -------------------------------------
5593
5594    function Make_Select_Specific_Data_Table
5595      (Typ : Entity_Id) return List_Id
5596    is
5597       Assignments : constant List_Id    := New_List;
5598       Loc         : constant Source_Ptr := Sloc (Typ);
5599
5600       Conc_Typ  : Entity_Id;
5601       Decls     : List_Id;
5602       DT_Ptr    : Entity_Id;
5603       Prim      : Entity_Id;
5604       Prim_Als  : Entity_Id;
5605       Prim_Elmt : Elmt_Id;
5606       Prim_Pos  : Uint;
5607       Nb_Prim   : Nat := 0;
5608
5609       type Examined_Array is array (Int range <>) of Boolean;
5610
5611       function Find_Entry_Index (E : Entity_Id) return Uint;
5612       --  Given an entry, find its index in the visible declarations of the
5613       --  corresponding concurrent type of Typ.
5614
5615       ----------------------
5616       -- Find_Entry_Index --
5617       ----------------------
5618
5619       function Find_Entry_Index (E : Entity_Id) return Uint is
5620          Index     : Uint := Uint_1;
5621          Subp_Decl : Entity_Id;
5622
5623       begin
5624          if Present (Decls)
5625            and then not Is_Empty_List (Decls)
5626          then
5627             Subp_Decl := First (Decls);
5628             while Present (Subp_Decl) loop
5629                if Nkind (Subp_Decl) = N_Entry_Declaration then
5630                   if Defining_Identifier (Subp_Decl) = E then
5631                      return Index;
5632                   end if;
5633
5634                   Index := Index + 1;
5635                end if;
5636
5637                Next (Subp_Decl);
5638             end loop;
5639          end if;
5640
5641          return Uint_0;
5642       end Find_Entry_Index;
5643
5644    --  Start of processing for Make_Select_Specific_Data_Table
5645
5646    begin
5647       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
5648
5649       DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
5650
5651       if Present (Corresponding_Concurrent_Type (Typ)) then
5652          Conc_Typ := Corresponding_Concurrent_Type (Typ);
5653
5654          if Present (Full_View (Conc_Typ)) then
5655             Conc_Typ := Full_View (Conc_Typ);
5656          end if;
5657
5658          if Ekind (Conc_Typ) = E_Protected_Type then
5659             Decls := Visible_Declarations (Protected_Definition (
5660                        Parent (Conc_Typ)));
5661          else
5662             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
5663             Decls := Visible_Declarations (Task_Definition (
5664                        Parent (Conc_Typ)));
5665          end if;
5666       end if;
5667
5668       --  Count the non-predefined primitive operations
5669
5670       Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5671       while Present (Prim_Elmt) loop
5672          Prim := Node (Prim_Elmt);
5673
5674          if not (Is_Predefined_Dispatching_Operation (Prim)
5675                    or else Is_Predefined_Dispatching_Alias (Prim))
5676          then
5677             Nb_Prim := Nb_Prim + 1;
5678          end if;
5679
5680          Next_Elmt (Prim_Elmt);
5681       end loop;
5682
5683       declare
5684          Examined : Examined_Array (1 .. Nb_Prim) := (others => False);
5685
5686       begin
5687          Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5688          while Present (Prim_Elmt) loop
5689             Prim := Node (Prim_Elmt);
5690
5691             --  Look for primitive overriding an abstract interface subprogram
5692
5693             if Present (Interface_Alias (Prim))
5694               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
5695             then
5696                Prim_Pos := DT_Position (Alias (Prim));
5697                pragma Assert (UI_To_Int (Prim_Pos) <= Nb_Prim);
5698                Examined (UI_To_Int (Prim_Pos)) := True;
5699
5700                --  Set the primitive operation kind regardless of subprogram
5701                --  type. Generate:
5702                --    Ada.Tags.Set_Prim_Op_Kind (DT_Ptr, <position>, <kind>);
5703
5704                Append_To (Assignments,
5705                  Make_Procedure_Call_Statement (Loc,
5706                    Name => New_Reference_To (RTE (RE_Set_Prim_Op_Kind), Loc),
5707                    Parameter_Associations => New_List (
5708                      New_Reference_To (DT_Ptr, Loc),
5709                      Make_Integer_Literal (Loc, Prim_Pos),
5710                      Prim_Op_Kind (Alias (Prim), Typ))));
5711
5712                --  Retrieve the root of the alias chain
5713
5714                Prim_Als := Prim;
5715                while Present (Alias (Prim_Als)) loop
5716                   Prim_Als := Alias (Prim_Als);
5717                end loop;
5718
5719                --  In the case of an entry wrapper, set the entry index
5720
5721                if Ekind (Prim) = E_Procedure
5722                  and then Is_Primitive_Wrapper (Prim_Als)
5723                  and then Ekind (Wrapped_Entity (Prim_Als)) = E_Entry
5724                then
5725                   --  Generate:
5726                   --    Ada.Tags.Set_Entry_Index
5727                   --      (DT_Ptr, <position>, <index>);
5728
5729                   Append_To (Assignments,
5730                     Make_Procedure_Call_Statement (Loc,
5731                       Name =>
5732                         New_Reference_To (RTE (RE_Set_Entry_Index), Loc),
5733                       Parameter_Associations => New_List (
5734                         New_Reference_To (DT_Ptr, Loc),
5735                         Make_Integer_Literal (Loc, Prim_Pos),
5736                         Make_Integer_Literal (Loc,
5737                           Find_Entry_Index (Wrapped_Entity (Prim_Als))))));
5738                end if;
5739             end if;
5740
5741             Next_Elmt (Prim_Elmt);
5742          end loop;
5743       end;
5744
5745       return Assignments;
5746    end Make_Select_Specific_Data_Table;
5747
5748    ---------------
5749    -- Make_Tags --
5750    ---------------
5751
5752    function Make_Tags (Typ : Entity_Id) return List_Id is
5753       Loc    : constant Source_Ptr := Sloc (Typ);
5754       Result : constant List_Id    := New_List;
5755
5756       procedure Import_DT
5757         (Tag_Typ         : Entity_Id;
5758          DT              : Entity_Id;
5759          Is_Secondary_DT : Boolean);
5760       --  Import the dispatch table DT of tagged type Tag_Typ. Required to
5761       --  generate forward references and statically allocate the table. For
5762       --  primary dispatch tables that require no dispatch table generate:
5763       --     DT : static aliased constant Non_Dispatch_Table_Wrapper;
5764       --     $pragma import (ada, DT);
5765       --  Otherwise generate:
5766       --     DT : static aliased constant Dispatch_Table_Wrapper (Nb_Prim);
5767       --     $pragma import (ada, DT);
5768
5769       ---------------
5770       -- Import_DT --
5771       ---------------
5772
5773       procedure Import_DT
5774         (Tag_Typ         : Entity_Id;
5775          DT              : Entity_Id;
5776          Is_Secondary_DT : Boolean)
5777       is
5778          DT_Constr_List : List_Id;
5779          Nb_Prim        : Nat;
5780
5781       begin
5782          Set_Is_Imported  (DT);
5783          Set_Ekind        (DT, E_Constant);
5784          Set_Related_Type (DT, Typ);
5785
5786          --  The scope must be set now to call Get_External_Name
5787
5788          Set_Scope (DT, Current_Scope);
5789
5790          Get_External_Name (DT, True);
5791          Set_Interface_Name (DT,
5792            Make_String_Literal (Loc,
5793              Strval => String_From_Name_Buffer));
5794
5795          --  Ensure proper Sprint output of this implicit importation
5796
5797          Set_Is_Internal (DT);
5798
5799          --  Save this entity to allow Make_DT to generate its exportation
5800
5801          Append_Elmt (DT, Dispatch_Table_Wrappers (Typ));
5802
5803          --  No dispatch table required
5804
5805          if not Is_Secondary_DT
5806            and then not Has_DT (Tag_Typ)
5807          then
5808             Append_To (Result,
5809               Make_Object_Declaration (Loc,
5810                 Defining_Identifier => DT,
5811                 Aliased_Present     => True,
5812                 Constant_Present    => True,
5813                 Object_Definition   =>
5814                   New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
5815
5816          else
5817             --  Calculate the number of primitives of the dispatch table and
5818             --  the size of the Type_Specific_Data record.
5819
5820             Nb_Prim :=
5821               UI_To_Int (DT_Entry_Count (First_Tag_Component (Tag_Typ)));
5822
5823             --  If the tagged type has no primitives we add a dummy slot
5824             --  whose address will be the tag of this type.
5825
5826             if Nb_Prim = 0 then
5827                DT_Constr_List :=
5828                  New_List (Make_Integer_Literal (Loc, 1));
5829             else
5830                DT_Constr_List :=
5831                  New_List (Make_Integer_Literal (Loc, Nb_Prim));
5832             end if;
5833
5834             Append_To (Result,
5835               Make_Object_Declaration (Loc,
5836                 Defining_Identifier => DT,
5837                 Aliased_Present     => True,
5838                 Constant_Present    => True,
5839                 Object_Definition   =>
5840                   Make_Subtype_Indication (Loc,
5841                     Subtype_Mark =>
5842                       New_Reference_To (RTE (RE_Dispatch_Table_Wrapper), Loc),
5843                     Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
5844                                     Constraints => DT_Constr_List))));
5845          end if;
5846       end Import_DT;
5847
5848       --  Local variables
5849
5850       Tname            : constant Name_Id := Chars (Typ);
5851       AI_Tag_Comp      : Elmt_Id;
5852       DT               : Node_Id;
5853       DT_Ptr           : Node_Id;
5854       Predef_Prims_Ptr : Node_Id;
5855       Iface_DT         : Node_Id;
5856       Iface_DT_Ptr     : Node_Id;
5857       Suffix_Index     : Int;
5858       Typ_Name         : Name_Id;
5859       Typ_Comps        : Elist_Id;
5860
5861    --  Start of processing for Make_Tags
5862
5863    begin
5864       --  1) Generate the primary and secondary tag entities
5865
5866       --  Collect the components associated with secondary dispatch tables
5867
5868       if Has_Interfaces (Typ) then
5869          Collect_Interface_Components (Typ, Typ_Comps);
5870       end if;
5871
5872       --  1) Generate the primary tag entities
5873
5874       --  Primary dispatch table containing user-defined primitives
5875
5876       DT_Ptr := Make_Defining_Identifier (Loc,
5877                   New_External_Name (Tname, 'P'));
5878       Set_Etype (DT_Ptr, RTE (RE_Tag));
5879
5880       --  Primary dispatch table containing predefined primitives
5881
5882       Predef_Prims_Ptr :=
5883         Make_Defining_Identifier (Loc,
5884           Chars => New_External_Name (Tname, 'Y'));
5885       Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
5886
5887       --  Import the forward declaration of the Dispatch Table wrapper record
5888       --  (Make_DT will take care of its exportation)
5889
5890       if Building_Static_DT (Typ) then
5891          Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
5892
5893          DT :=
5894            Make_Defining_Identifier (Loc,
5895              Chars => New_External_Name (Tname, 'T'));
5896
5897          Import_DT (Typ, DT, Is_Secondary_DT => False);
5898
5899          if Has_DT (Typ) then
5900             Append_To (Result,
5901               Make_Object_Declaration (Loc,
5902                 Defining_Identifier => DT_Ptr,
5903                 Constant_Present    => True,
5904                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
5905                 Expression =>
5906                   Unchecked_Convert_To (RTE (RE_Tag),
5907                     Make_Attribute_Reference (Loc,
5908                       Prefix =>
5909                         Make_Selected_Component (Loc,
5910                           Prefix => New_Reference_To (DT, Loc),
5911                         Selector_Name =>
5912                           New_Occurrence_Of
5913                             (RTE_Record_Component (RE_Prims_Ptr), Loc)),
5914                       Attribute_Name => Name_Address))));
5915
5916             Append_To (Result,
5917               Make_Object_Declaration (Loc,
5918                 Defining_Identifier => Predef_Prims_Ptr,
5919                 Constant_Present    => True,
5920                 Object_Definition   => New_Reference_To
5921                                             (RTE (RE_Address), Loc),
5922                 Expression =>
5923                   Make_Attribute_Reference (Loc,
5924                     Prefix =>
5925                       Make_Selected_Component (Loc,
5926                         Prefix => New_Reference_To (DT, Loc),
5927                       Selector_Name =>
5928                         New_Occurrence_Of
5929                           (RTE_Record_Component (RE_Predef_Prims), Loc)),
5930                     Attribute_Name => Name_Address)));
5931
5932          --  No dispatch table required
5933
5934          else
5935             Append_To (Result,
5936               Make_Object_Declaration (Loc,
5937                 Defining_Identifier => DT_Ptr,
5938                 Constant_Present    => True,
5939                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
5940                 Expression =>
5941                   Unchecked_Convert_To (RTE (RE_Tag),
5942                     Make_Attribute_Reference (Loc,
5943                       Prefix =>
5944                         Make_Selected_Component (Loc,
5945                           Prefix => New_Reference_To (DT, Loc),
5946                         Selector_Name =>
5947                           New_Occurrence_Of
5948                             (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
5949                       Attribute_Name => Name_Address))));
5950          end if;
5951
5952          Set_Is_True_Constant (DT_Ptr);
5953          Set_Is_Statically_Allocated (DT_Ptr);
5954       end if;
5955
5956       pragma Assert (No (Access_Disp_Table (Typ)));
5957       Set_Access_Disp_Table (Typ, New_Elmt_List);
5958       Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
5959       Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
5960
5961       --  2) Generate the secondary tag entities
5962
5963       if Has_Interfaces (Typ) then
5964
5965          --  Note: The following value of Suffix_Index must be in sync with
5966          --  the Suffix_Index values of secondary dispatch tables generated
5967          --  by Make_DT.
5968
5969          Suffix_Index := 1;
5970
5971          --  For each interface type we build an unique external name
5972          --  associated with its corresponding secondary dispatch table.
5973          --  This external name will be used to declare an object that
5974          --  references this secondary dispatch table, value that will be
5975          --  used for the elaboration of Typ's objects and also for the
5976          --  elaboration of objects of derivations of Typ that do not
5977          --  override the primitive operation of this interface type.
5978
5979          AI_Tag_Comp := First_Elmt (Typ_Comps);
5980          while Present (AI_Tag_Comp) loop
5981             Get_Secondary_DT_External_Name
5982               (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
5983             Typ_Name := Name_Find;
5984
5985             if Building_Static_DT (Typ) then
5986                Iface_DT :=
5987                  Make_Defining_Identifier (Loc,
5988                    Chars => New_External_Name
5989                               (Typ_Name, 'T', Suffix_Index => -1));
5990                Import_DT
5991                  (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
5992                   DT      => Iface_DT,
5993                   Is_Secondary_DT => True);
5994             end if;
5995
5996             --  Secondary dispatch table referencing thunks to user-defined
5997             --  primitives covered by this interface.
5998
5999             Iface_DT_Ptr :=
6000               Make_Defining_Identifier (Loc,
6001                 Chars => New_External_Name (Typ_Name, 'P'));
6002             Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6003             Set_Ekind (Iface_DT_Ptr, E_Constant);
6004             Set_Is_Tag (Iface_DT_Ptr);
6005             Set_Has_Thunks (Iface_DT_Ptr);
6006             Set_Is_Statically_Allocated (Iface_DT_Ptr,
6007               Is_Library_Level_Tagged_Type (Typ));
6008             Set_Is_True_Constant (Iface_DT_Ptr);
6009             Set_Related_Type
6010               (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6011             Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6012
6013             if Building_Static_DT (Typ) then
6014                Append_To (Result,
6015                  Make_Object_Declaration (Loc,
6016                    Defining_Identifier => Iface_DT_Ptr,
6017                    Constant_Present    => True,
6018                    Object_Definition   => New_Reference_To
6019                                             (RTE (RE_Interface_Tag), Loc),
6020                    Expression =>
6021                      Unchecked_Convert_To (RTE (RE_Interface_Tag),
6022                        Make_Attribute_Reference (Loc,
6023                          Prefix =>
6024                            Make_Selected_Component (Loc,
6025                              Prefix => New_Reference_To (Iface_DT, Loc),
6026                            Selector_Name =>
6027                              New_Occurrence_Of
6028                                (RTE_Record_Component (RE_Prims_Ptr), Loc)),
6029                          Attribute_Name => Name_Address))));
6030             end if;
6031
6032             --  Secondary dispatch table referencing thunks to predefined
6033             --  primitives.
6034
6035             Iface_DT_Ptr :=
6036               Make_Defining_Identifier (Loc,
6037                 Chars => New_External_Name (Typ_Name, 'Y'));
6038             Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
6039             Set_Ekind (Iface_DT_Ptr, E_Constant);
6040             Set_Is_Tag (Iface_DT_Ptr);
6041             Set_Has_Thunks (Iface_DT_Ptr);
6042             Set_Is_Statically_Allocated (Iface_DT_Ptr,
6043               Is_Library_Level_Tagged_Type (Typ));
6044             Set_Is_True_Constant (Iface_DT_Ptr);
6045             Set_Related_Type
6046               (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6047             Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6048
6049             --  Secondary dispatch table referencing user-defined primitives
6050             --  covered by this interface.
6051
6052             Iface_DT_Ptr :=
6053               Make_Defining_Identifier (Loc,
6054                 Chars => New_External_Name (Typ_Name, 'D'));
6055             Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
6056             Set_Ekind (Iface_DT_Ptr, E_Constant);
6057             Set_Is_Tag (Iface_DT_Ptr);
6058             Set_Is_Statically_Allocated (Iface_DT_Ptr,
6059               Is_Library_Level_Tagged_Type (Typ));
6060             Set_Is_True_Constant (Iface_DT_Ptr);
6061             Set_Related_Type
6062               (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6063             Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6064
6065             --  Secondary dispatch table referencing predefined primitives
6066
6067             Iface_DT_Ptr :=
6068               Make_Defining_Identifier (Loc,
6069                 Chars => New_External_Name (Typ_Name, 'Z'));
6070             Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
6071             Set_Ekind (Iface_DT_Ptr, E_Constant);
6072             Set_Is_Tag (Iface_DT_Ptr);
6073             Set_Is_Statically_Allocated (Iface_DT_Ptr,
6074               Is_Library_Level_Tagged_Type (Typ));
6075             Set_Is_True_Constant (Iface_DT_Ptr);
6076             Set_Related_Type
6077               (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
6078             Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
6079
6080             Next_Elmt (AI_Tag_Comp);
6081          end loop;
6082       end if;
6083
6084       --  3) At the end of Access_Disp_Table we add the entity of an access
6085       --     type declaration. It is used by Build_Get_Prim_Op_Address to
6086       --     expand dispatching calls through the primary dispatch table.
6087
6088       --     Generate:
6089       --       type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
6090       --       type Typ_DT_Acc is access Typ_DT;
6091
6092       declare
6093          Name_DT_Prims     : constant Name_Id :=
6094                                New_External_Name (Tname, 'G');
6095          Name_DT_Prims_Acc : constant Name_Id :=
6096                                New_External_Name (Tname, 'H');
6097          DT_Prims          : constant Entity_Id :=
6098                                Make_Defining_Identifier (Loc, Name_DT_Prims);
6099          DT_Prims_Acc      : constant Entity_Id :=
6100                                Make_Defining_Identifier (Loc,
6101                                  Name_DT_Prims_Acc);
6102       begin
6103          Append_To (Result,
6104            Make_Full_Type_Declaration (Loc,
6105              Defining_Identifier => DT_Prims,
6106              Type_Definition =>
6107                Make_Constrained_Array_Definition (Loc,
6108                  Discrete_Subtype_Definitions => New_List (
6109                    Make_Range (Loc,
6110                      Low_Bound  => Make_Integer_Literal (Loc, 1),
6111                      High_Bound => Make_Integer_Literal (Loc,
6112                                     DT_Entry_Count
6113                                       (First_Tag_Component (Typ))))),
6114                  Component_Definition =>
6115                    Make_Component_Definition (Loc,
6116                      Subtype_Indication =>
6117                        New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
6118
6119          Append_To (Result,
6120            Make_Full_Type_Declaration (Loc,
6121              Defining_Identifier => DT_Prims_Acc,
6122              Type_Definition =>
6123                 Make_Access_To_Object_Definition (Loc,
6124                   Subtype_Indication =>
6125                     New_Occurrence_Of (DT_Prims, Loc))));
6126
6127          Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
6128
6129          --  Analyze the resulting list and suppress the generation of the
6130          --  Init_Proc associated with the above array declaration because
6131          --  we never use such type in object declarations; this type is only
6132          --  used to simplify the expansion associated with dispatching calls.
6133
6134          Analyze_List (Result);
6135          Set_Suppress_Init_Proc (Base_Type (DT_Prims));
6136
6137          --  Mark entity of dispatch table. Required by the backend to handle
6138          --  the properly.
6139
6140          Set_Is_Dispatch_Table_Entity (DT_Prims);
6141       end;
6142
6143       Set_Ekind        (DT_Ptr, E_Constant);
6144       Set_Is_Tag       (DT_Ptr);
6145       Set_Related_Type (DT_Ptr, Typ);
6146
6147       return Result;
6148    end Make_Tags;
6149
6150    -----------------------------------
6151    -- Original_View_In_Visible_Part --
6152    -----------------------------------
6153
6154    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
6155       Scop : constant Entity_Id := Scope (Typ);
6156
6157    begin
6158       --  The scope must be a package
6159
6160       if not Is_Package_Or_Generic_Package (Scop) then
6161          return False;
6162       end if;
6163
6164       --  A type with a private declaration has a private view declared in
6165       --  the visible part.
6166
6167       if Has_Private_Declaration (Typ) then
6168          return True;
6169       end if;
6170
6171       return List_Containing (Parent (Typ)) =
6172         Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
6173    end Original_View_In_Visible_Part;
6174
6175    ------------------
6176    -- Prim_Op_Kind --
6177    ------------------
6178
6179    function Prim_Op_Kind
6180      (Prim : Entity_Id;
6181       Typ  : Entity_Id) return Node_Id
6182    is
6183       Full_Typ : Entity_Id := Typ;
6184       Loc      : constant Source_Ptr := Sloc (Prim);
6185       Prim_Op  : Entity_Id;
6186
6187    begin
6188       --  Retrieve the original primitive operation
6189
6190       Prim_Op := Prim;
6191       while Present (Alias (Prim_Op)) loop
6192          Prim_Op := Alias (Prim_Op);
6193       end loop;
6194
6195       if Ekind (Typ) = E_Record_Type
6196         and then Present (Corresponding_Concurrent_Type (Typ))
6197       then
6198          Full_Typ := Corresponding_Concurrent_Type (Typ);
6199       end if;
6200
6201       --  When a private tagged type is completed by a concurrent type,
6202       --  retrieve the full view.
6203
6204       if Is_Private_Type (Full_Typ) then
6205          Full_Typ := Full_View (Full_Typ);
6206       end if;
6207
6208       if Ekind (Prim_Op) = E_Function then
6209
6210          --  Protected function
6211
6212          if Ekind (Full_Typ) = E_Protected_Type then
6213             return New_Reference_To (RTE (RE_POK_Protected_Function), Loc);
6214
6215          --  Task function
6216
6217          elsif Ekind (Full_Typ) = E_Task_Type then
6218             return New_Reference_To (RTE (RE_POK_Task_Function), Loc);
6219
6220          --  Regular function
6221
6222          else
6223             return New_Reference_To (RTE (RE_POK_Function), Loc);
6224          end if;
6225
6226       else
6227          pragma Assert (Ekind (Prim_Op) = E_Procedure);
6228
6229          if Ekind (Full_Typ) = E_Protected_Type then
6230
6231             --  Protected entry
6232
6233             if Is_Primitive_Wrapper (Prim_Op)
6234               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
6235             then
6236                return New_Reference_To (RTE (RE_POK_Protected_Entry), Loc);
6237
6238             --  Protected procedure
6239
6240             else
6241                return New_Reference_To (RTE (RE_POK_Protected_Procedure), Loc);
6242             end if;
6243
6244          elsif Ekind (Full_Typ) = E_Task_Type then
6245
6246             --  Task entry
6247
6248             if Is_Primitive_Wrapper (Prim_Op)
6249               and then Ekind (Wrapped_Entity (Prim_Op)) = E_Entry
6250             then
6251                return New_Reference_To (RTE (RE_POK_Task_Entry), Loc);
6252
6253             --  Task "procedure". These are the internally Expander-generated
6254             --  procedures (task body for instance).
6255
6256             else
6257                return New_Reference_To (RTE (RE_POK_Task_Procedure), Loc);
6258             end if;
6259
6260          --  Regular procedure
6261
6262          else
6263             return New_Reference_To (RTE (RE_POK_Procedure), Loc);
6264          end if;
6265       end if;
6266    end Prim_Op_Kind;
6267
6268    ------------------------
6269    -- Register_Primitive --
6270    ------------------------
6271
6272    procedure Register_Primitive
6273      (Loc     : Source_Ptr;
6274       Prim    : Entity_Id;
6275       Ins_Nod : Node_Id)
6276    is
6277       DT_Ptr        : Entity_Id;
6278       Iface_Prim    : Entity_Id;
6279       Iface_Typ     : Entity_Id;
6280       Iface_DT_Ptr  : Entity_Id;
6281       Iface_DT_Elmt : Elmt_Id;
6282       L             : List_Id;
6283       Pos           : Uint;
6284       Tag           : Entity_Id;
6285       Tag_Typ       : Entity_Id;
6286       Thunk_Id      : Entity_Id;
6287       Thunk_Code    : Node_Id;
6288
6289    begin
6290       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
6291
6292       if not RTE_Available (RE_Tag) then
6293          return;
6294       end if;
6295
6296       if not Present (Interface_Alias (Prim)) then
6297          Tag_Typ := Scope (DTC_Entity (Prim));
6298          Pos := DT_Position (Prim);
6299          Tag := First_Tag_Component (Tag_Typ);
6300
6301          if Is_Predefined_Dispatching_Operation (Prim)
6302            or else Is_Predefined_Dispatching_Alias (Prim)
6303          then
6304             DT_Ptr :=
6305               Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
6306
6307             Insert_After (Ins_Nod,
6308               Build_Set_Predefined_Prim_Op_Address (Loc,
6309                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
6310                 Position     => Pos,
6311                 Address_Node =>
6312                   Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6313                     Make_Attribute_Reference (Loc,
6314                       Prefix => New_Reference_To (Prim, Loc),
6315                       Attribute_Name => Name_Unrestricted_Access))));
6316
6317             --  Register copy of the pointer to the 'size primitive in the TSD
6318
6319             if Chars (Prim) = Name_uSize
6320               and then RTE_Record_Component_Available (RE_Size_Func)
6321             then
6322                DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
6323                Insert_After (Ins_Nod,
6324                  Build_Set_Size_Function (Loc,
6325                    Tag_Node  => New_Reference_To (DT_Ptr, Loc),
6326                    Size_Func => Prim));
6327             end if;
6328
6329          else
6330             pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
6331
6332             DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
6333             Insert_After (Ins_Nod,
6334               Build_Set_Prim_Op_Address (Loc,
6335                 Typ          => Tag_Typ,
6336                 Tag_Node     => New_Reference_To (DT_Ptr, Loc),
6337                 Position     => Pos,
6338                 Address_Node =>
6339                   Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6340                     Make_Attribute_Reference (Loc,
6341                       Prefix => New_Reference_To (Prim, Loc),
6342                       Attribute_Name => Name_Unrestricted_Access))));
6343          end if;
6344
6345       --  Ada 2005 (AI-251): Primitive associated with an interface type
6346       --  Generate the code of the thunk only if the interface type is not an
6347       --  immediate ancestor of Typ; otherwise the dispatch table associated
6348       --  with the interface is the primary dispatch table and we have nothing
6349       --  else to do here.
6350
6351       else
6352          Tag_Typ   := Find_Dispatching_Type (Alias (Prim));
6353          Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
6354
6355          pragma Assert (Is_Interface (Iface_Typ));
6356
6357          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
6358
6359          if not Is_Ancestor (Iface_Typ, Tag_Typ)
6360            and then Present (Thunk_Code)
6361          then
6362             --  Comment needed on why checks are suppressed. This is not just
6363             --  efficiency, but fundamental functionality (see 1.295 RH, which
6364             --  still does not answer this question) ???
6365
6366             Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks);
6367
6368             --  Generate the code necessary to fill the appropriate entry of
6369             --  the secondary dispatch table of Prim's controlling type with
6370             --  Thunk_Id's address.
6371
6372             Iface_DT_Elmt := Find_Interface_ADT (Tag_Typ, Iface_Typ);
6373             Iface_DT_Ptr  := Node (Iface_DT_Elmt);
6374             pragma Assert (Has_Thunks (Iface_DT_Ptr));
6375
6376             Iface_Prim := Interface_Alias (Prim);
6377             Pos        := DT_Position (Iface_Prim);
6378             Tag        := First_Tag_Component (Iface_Typ);
6379             L          := New_List;
6380
6381             if Is_Predefined_Dispatching_Operation (Prim)
6382               or else Is_Predefined_Dispatching_Alias (Prim)
6383             then
6384                Append_To (L,
6385                  Build_Set_Predefined_Prim_Op_Address (Loc,
6386                    Tag_Node =>
6387                      New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
6388                    Position => Pos,
6389                    Address_Node =>
6390                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6391                        Make_Attribute_Reference (Loc,
6392                          Prefix          => New_Reference_To (Thunk_Id, Loc),
6393                          Attribute_Name  => Name_Unrestricted_Access))));
6394
6395                Next_Elmt (Iface_DT_Elmt);
6396                Next_Elmt (Iface_DT_Elmt);
6397                Iface_DT_Ptr := Node (Iface_DT_Elmt);
6398                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
6399
6400                Append_To (L,
6401                  Build_Set_Predefined_Prim_Op_Address (Loc,
6402                    Tag_Node =>
6403                      New_Reference_To (Node (Next_Elmt (Iface_DT_Elmt)), Loc),
6404                    Position => Pos,
6405                    Address_Node =>
6406                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6407                        Make_Attribute_Reference (Loc,
6408                          Prefix => New_Reference_To (Alias (Prim), Loc),
6409                          Attribute_Name  => Name_Unrestricted_Access))));
6410
6411                Insert_Actions_After (Ins_Nod, L);
6412
6413             else
6414                pragma Assert (Pos /= Uint_0
6415                  and then Pos <= DT_Entry_Count (Tag));
6416
6417                Append_To (L,
6418                  Build_Set_Prim_Op_Address (Loc,
6419                    Typ          => Iface_Typ,
6420                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
6421                    Position     => Pos,
6422                    Address_Node =>
6423                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6424                        Make_Attribute_Reference (Loc,
6425                          Prefix => New_Reference_To (Thunk_Id, Loc),
6426                          Attribute_Name => Name_Unrestricted_Access))));
6427
6428                Next_Elmt (Iface_DT_Elmt);
6429                Next_Elmt (Iface_DT_Elmt);
6430                Iface_DT_Ptr := Node (Iface_DT_Elmt);
6431                pragma Assert (not Has_Thunks (Iface_DT_Ptr));
6432
6433                Append_To (L,
6434                  Build_Set_Prim_Op_Address (Loc,
6435                    Typ          => Iface_Typ,
6436                    Tag_Node     => New_Reference_To (Iface_DT_Ptr, Loc),
6437                    Position     => Pos,
6438                    Address_Node =>
6439                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
6440                        Make_Attribute_Reference (Loc,
6441                          Prefix => New_Reference_To (Alias (Prim), Loc),
6442                          Attribute_Name => Name_Unrestricted_Access))));
6443
6444                Insert_Actions_After (Ins_Nod, L);
6445             end if;
6446          end if;
6447       end if;
6448    end Register_Primitive;
6449
6450    -------------------------
6451    -- Set_All_DT_Position --
6452    -------------------------
6453
6454    procedure Set_All_DT_Position (Typ : Entity_Id) is
6455
6456       procedure Validate_Position (Prim : Entity_Id);
6457       --  Check that the position assigned to Prim is completely safe
6458       --  (it has not been assigned to a previously defined primitive
6459       --   operation of Typ)
6460
6461       -----------------------
6462       -- Validate_Position --
6463       -----------------------
6464
6465       procedure Validate_Position (Prim : Entity_Id) is
6466          Op_Elmt : Elmt_Id;
6467          Op      : Entity_Id;
6468
6469       begin
6470          --  Aliased primitives are safe
6471
6472          if Present (Alias (Prim)) then
6473             return;
6474          end if;
6475
6476          Op_Elmt := First_Elmt (Primitive_Operations (Typ));
6477          while Present (Op_Elmt) loop
6478             Op := Node (Op_Elmt);
6479
6480             --  No need to check against itself
6481
6482             if Op = Prim then
6483                null;
6484
6485             --  Primitive operations covering abstract interfaces are
6486             --  allocated later
6487
6488             elsif Present (Interface_Alias (Op)) then
6489                null;
6490
6491             --  Predefined dispatching operations are completely safe. They
6492             --  are allocated at fixed positions in a separate table.
6493
6494             elsif Is_Predefined_Dispatching_Operation (Op)
6495                or else Is_Predefined_Dispatching_Alias (Op)
6496             then
6497                null;
6498
6499             --  Aliased subprograms are safe
6500
6501             elsif Present (Alias (Op)) then
6502                null;
6503
6504             elsif DT_Position (Op) = DT_Position (Prim)
6505                and then not Is_Predefined_Dispatching_Operation (Op)
6506                and then not Is_Predefined_Dispatching_Operation (Prim)
6507                and then not Is_Predefined_Dispatching_Alias (Op)
6508                and then not Is_Predefined_Dispatching_Alias (Prim)
6509             then
6510
6511                --  Handle aliased subprograms
6512
6513                declare
6514                   Op_1 : Entity_Id;
6515                   Op_2 : Entity_Id;
6516
6517                begin
6518                   Op_1 := Op;
6519                   loop
6520                      if Present (Overridden_Operation (Op_1)) then
6521                         Op_1 := Overridden_Operation (Op_1);
6522                      elsif Present (Alias (Op_1)) then
6523                         Op_1 := Alias (Op_1);
6524                      else
6525                         exit;
6526                      end if;
6527                   end loop;
6528
6529                   Op_2 := Prim;
6530                   loop
6531                      if Present (Overridden_Operation (Op_2)) then
6532                         Op_2 := Overridden_Operation (Op_2);
6533                      elsif Present (Alias (Op_2)) then
6534                         Op_2 := Alias (Op_2);
6535                      else
6536                         exit;
6537                      end if;
6538                   end loop;
6539
6540                   if Op_1 /= Op_2 then
6541                      raise Program_Error;
6542                   end if;
6543                end;
6544             end if;
6545
6546             Next_Elmt (Op_Elmt);
6547          end loop;
6548       end Validate_Position;
6549
6550       --  Local variables
6551
6552       Parent_Typ : constant Entity_Id := Etype (Typ);
6553       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
6554       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
6555
6556       Adjusted   : Boolean := False;
6557       Finalized  : Boolean := False;
6558
6559       Count_Prim : Nat;
6560       DT_Length  : Nat;
6561       Nb_Prim    : Nat;
6562       Prim       : Entity_Id;
6563       Prim_Elmt  : Elmt_Id;
6564
6565    --  Start of processing for Set_All_DT_Position
6566
6567    begin
6568       pragma Assert (Present (First_Tag_Component (Typ)));
6569
6570       --  Set the DT_Position for each primitive operation. Perform some
6571       --  sanity checks to avoid to build completely inconsistent dispatch
6572       --  tables.
6573
6574       --  First stage: Set the DTC entity of all the primitive operations
6575       --  This is required to properly read the DT_Position attribute in
6576       --  the latter stages.
6577
6578       Prim_Elmt  := First_Prim;
6579       Count_Prim := 0;
6580       while Present (Prim_Elmt) loop
6581          Prim := Node (Prim_Elmt);
6582
6583          --  Predefined primitives have a separate dispatch table
6584
6585          if not (Is_Predefined_Dispatching_Operation (Prim)
6586                    or else Is_Predefined_Dispatching_Alias (Prim))
6587          then
6588             Count_Prim := Count_Prim + 1;
6589          end if;
6590
6591          Set_DTC_Entity_Value (Typ, Prim);
6592
6593          --  Clear any previous value of the DT_Position attribute. In this
6594          --  way we ensure that the final position of all the primitives is
6595          --  established by the following stages of this algorithm.
6596
6597          Set_DT_Position (Prim, No_Uint);
6598
6599          Next_Elmt (Prim_Elmt);
6600       end loop;
6601
6602       declare
6603          Fixed_Prim : array (Int range 0 .. Count_Prim) of Boolean :=
6604                         (others => False);
6605
6606          E : Entity_Id;
6607
6608          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id);
6609          --  Called if Typ is declared in a nested package or a public child
6610          --  package to handle inherited primitives that were inherited by Typ
6611          --  in  the visible part, but whose declaration was deferred because
6612          --  the parent operation was private and not visible at that point.
6613
6614          procedure Set_Fixed_Prim (Pos : Nat);
6615          --  Sets to true an element of the Fixed_Prim table to indicate
6616          --  that this entry of the dispatch table of Typ is occupied.
6617
6618          ------------------------------------------
6619          -- Handle_Inherited_Private_Subprograms --
6620          ------------------------------------------
6621
6622          procedure Handle_Inherited_Private_Subprograms (Typ : Entity_Id) is
6623             Op_List     : Elist_Id;
6624             Op_Elmt     : Elmt_Id;
6625             Op_Elmt_2   : Elmt_Id;
6626             Prim_Op     : Entity_Id;
6627             Parent_Subp : Entity_Id;
6628
6629          begin
6630             Op_List := Primitive_Operations (Typ);
6631
6632             Op_Elmt := First_Elmt (Op_List);
6633             while Present (Op_Elmt) loop
6634                Prim_Op := Node (Op_Elmt);
6635
6636                --  Search primitives that are implicit operations with an
6637                --  internal name whose parent operation has a normal name.
6638
6639                if Present (Alias (Prim_Op))
6640                  and then Find_Dispatching_Type (Alias (Prim_Op)) /= Typ
6641                  and then not Comes_From_Source (Prim_Op)
6642                  and then Is_Internal_Name (Chars (Prim_Op))
6643                  and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
6644                then
6645                   Parent_Subp := Alias (Prim_Op);
6646
6647                   --  Check if the type has an explicit overriding for this
6648                   --  primitive.
6649
6650                   Op_Elmt_2 := Next_Elmt (Op_Elmt);
6651                   while Present (Op_Elmt_2) loop
6652                      if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
6653                        and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
6654                      then
6655                         Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
6656                         Set_DT_Position (Node (Op_Elmt_2),
6657                           DT_Position (Parent_Subp));
6658                         Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
6659
6660                         goto Next_Primitive;
6661                      end if;
6662
6663                      Next_Elmt (Op_Elmt_2);
6664                   end loop;
6665                end if;
6666
6667                <<Next_Primitive>>
6668                Next_Elmt (Op_Elmt);
6669             end loop;
6670          end Handle_Inherited_Private_Subprograms;
6671
6672          --------------------
6673          -- Set_Fixed_Prim --
6674          --------------------
6675
6676          procedure Set_Fixed_Prim (Pos : Nat) is
6677          begin
6678             pragma Assert (Pos <= Count_Prim);
6679             Fixed_Prim (Pos) := True;
6680          exception
6681             when Constraint_Error =>
6682                raise Program_Error;
6683          end Set_Fixed_Prim;
6684
6685       begin
6686          --  In case of nested packages and public child package it may be
6687          --  necessary a special management on inherited subprograms so that
6688          --  the dispatch table is properly filled.
6689
6690          if Ekind (Scope (Scope (Typ))) = E_Package
6691            and then Scope (Scope (Typ)) /= Standard_Standard
6692            and then ((Is_Derived_Type (Typ) and then not Is_Private_Type (Typ))
6693                        or else
6694                         (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
6695                           and then Is_Generic_Type (Typ)))
6696            and then In_Open_Scopes (Scope (Etype (Typ)))
6697            and then Typ = Base_Type (Typ)
6698          then
6699             Handle_Inherited_Private_Subprograms (Typ);
6700          end if;
6701
6702          --  Second stage: Register fixed entries
6703
6704          Nb_Prim   := 0;
6705          Prim_Elmt := First_Prim;
6706          while Present (Prim_Elmt) loop
6707             Prim := Node (Prim_Elmt);
6708
6709             --  Predefined primitives have a separate table and all its
6710             --  entries are at predefined fixed positions.
6711
6712             if Is_Predefined_Dispatching_Operation (Prim) then
6713                Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
6714
6715             elsif Is_Predefined_Dispatching_Alias (Prim) then
6716                E := Alias (Prim);
6717                while Present (Alias (E)) loop
6718                   E := Alias (E);
6719                end loop;
6720
6721                Set_DT_Position (Prim, Default_Prim_Op_Position (E));
6722
6723             --  Overriding primitives of ancestor abstract interfaces
6724
6725             elsif Present (Interface_Alias (Prim))
6726               and then Is_Ancestor
6727                          (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
6728             then
6729                pragma Assert (DT_Position (Prim) = No_Uint
6730                  and then Present (DTC_Entity (Interface_Alias (Prim))));
6731
6732                E := Interface_Alias (Prim);
6733                Set_DT_Position (Prim, DT_Position (E));
6734
6735                pragma Assert
6736                  (DT_Position (Alias (Prim)) = No_Uint
6737                     or else DT_Position (Alias (Prim)) = DT_Position (E));
6738                Set_DT_Position (Alias (Prim), DT_Position (E));
6739                Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
6740
6741             --  Overriding primitives must use the same entry as the
6742             --  overridden primitive.
6743
6744             elsif not Present (Interface_Alias (Prim))
6745               and then Present (Alias (Prim))
6746               and then Chars (Prim) = Chars (Alias (Prim))
6747               and then Find_Dispatching_Type (Alias (Prim)) /= Typ
6748               and then Is_Ancestor
6749                          (Find_Dispatching_Type (Alias (Prim)), Typ)
6750               and then Present (DTC_Entity (Alias (Prim)))
6751             then
6752                E := Alias (Prim);
6753                Set_DT_Position (Prim, DT_Position (E));
6754
6755                if not Is_Predefined_Dispatching_Alias (E) then
6756                   Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
6757                end if;
6758             end if;
6759
6760             Next_Elmt (Prim_Elmt);
6761          end loop;
6762
6763          --  Third stage: Fix the position of all the new primitives
6764          --  Entries associated with primitives covering interfaces
6765          --  are handled in a latter round.
6766
6767          Prim_Elmt := First_Prim;
6768          while Present (Prim_Elmt) loop
6769             Prim := Node (Prim_Elmt);
6770
6771             --  Skip primitives previously set entries
6772
6773             if DT_Position (Prim) /= No_Uint then
6774                null;
6775
6776             --  Primitives covering interface primitives are handled later
6777
6778             elsif Present (Interface_Alias (Prim)) then
6779                null;
6780
6781             else
6782                --  Take the next available position in the DT
6783
6784                loop
6785                   Nb_Prim := Nb_Prim + 1;
6786                   pragma Assert (Nb_Prim <= Count_Prim);
6787                   exit when not Fixed_Prim (Nb_Prim);
6788                end loop;
6789
6790                Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
6791                Set_Fixed_Prim (Nb_Prim);
6792             end if;
6793
6794             Next_Elmt (Prim_Elmt);
6795          end loop;
6796       end;
6797
6798       --  Fourth stage: Complete the decoration of primitives covering
6799       --  interfaces (that is, propagate the DT_Position attribute
6800       --  from the aliased primitive)
6801
6802       Prim_Elmt := First_Prim;
6803       while Present (Prim_Elmt) loop
6804          Prim := Node (Prim_Elmt);
6805
6806          if DT_Position (Prim) = No_Uint
6807            and then Present (Interface_Alias (Prim))
6808          then
6809             pragma Assert (Present (Alias (Prim))
6810               and then Find_Dispatching_Type (Alias (Prim)) = Typ);
6811
6812             --  Check if this entry will be placed in the primary DT
6813
6814             if Is_Ancestor
6815                 (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
6816             then
6817                pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
6818                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
6819
6820             --  Otherwise it will be placed in the secondary DT
6821
6822             else
6823                pragma Assert
6824                  (DT_Position (Interface_Alias (Prim)) /= No_Uint);
6825                Set_DT_Position (Prim,
6826                  DT_Position (Interface_Alias (Prim)));
6827             end if;
6828          end if;
6829
6830          Next_Elmt (Prim_Elmt);
6831       end loop;
6832
6833       --  Generate listing showing the contents of the dispatch tables.
6834       --  This action is done before some further static checks because
6835       --  in case of critical errors caused by a wrong dispatch table
6836       --  we need to see the contents of such table.
6837
6838       if Debug_Flag_ZZ then
6839          Write_DT (Typ);
6840       end if;
6841
6842       --  Final stage: Ensure that the table is correct plus some further
6843       --  verifications concerning the primitives.
6844
6845       Prim_Elmt := First_Prim;
6846       DT_Length := 0;
6847       while Present (Prim_Elmt) loop
6848          Prim := Node (Prim_Elmt);
6849
6850          --  At this point all the primitives MUST have a position
6851          --  in the dispatch table.
6852
6853          if DT_Position (Prim) = No_Uint then
6854             raise Program_Error;
6855          end if;
6856
6857          --  Calculate real size of the dispatch table
6858
6859          if not (Is_Predefined_Dispatching_Operation (Prim)
6860                    or else Is_Predefined_Dispatching_Alias (Prim))
6861            and then UI_To_Int (DT_Position (Prim)) > DT_Length
6862          then
6863             DT_Length := UI_To_Int (DT_Position (Prim));
6864          end if;
6865
6866          --  Ensure that the assigned position to non-predefined
6867          --  dispatching operations in the dispatch table is correct.
6868
6869          if not (Is_Predefined_Dispatching_Operation (Prim)
6870                    or else Is_Predefined_Dispatching_Alias (Prim))
6871          then
6872             Validate_Position (Prim);
6873          end if;
6874
6875          if Chars (Prim) = Name_Finalize then
6876             Finalized := True;
6877          end if;
6878
6879          if Chars (Prim) = Name_Adjust then
6880             Adjusted := True;
6881          end if;
6882
6883          --  An abstract operation cannot be declared in the private part
6884          --  for a visible abstract type, because it could never be over-
6885          --  ridden. For explicit declarations this is checked at the
6886          --  point of declaration, but for inherited operations it must
6887          --  be done when building the dispatch table.
6888
6889          --  Ada 2005 (AI-251): Primitives associated with interfaces are
6890          --  excluded from this check because interfaces must be visible in
6891          --  the public and private part (RM 7.3 (7.3/2))
6892
6893          if Is_Abstract_Type (Typ)
6894            and then Is_Abstract_Subprogram (Prim)
6895            and then Present (Alias (Prim))
6896            and then not Is_Interface
6897                           (Find_Dispatching_Type (Ultimate_Alias (Prim)))
6898            and then not Present (Interface_Alias (Prim))
6899            and then Is_Derived_Type (Typ)
6900            and then In_Private_Part (Current_Scope)
6901            and then
6902              List_Containing (Parent (Prim)) =
6903                Private_Declarations
6904                 (Specification (Unit_Declaration_Node (Current_Scope)))
6905            and then Original_View_In_Visible_Part (Typ)
6906          then
6907             --  We exclude Input and Output stream operations because
6908             --  Limited_Controlled inherits useless Input and Output
6909             --  stream operations from Root_Controlled, which can
6910             --  never be overridden.
6911
6912             if not Is_TSS (Prim, TSS_Stream_Input)
6913                  and then
6914                not Is_TSS (Prim, TSS_Stream_Output)
6915             then
6916                Error_Msg_NE
6917                  ("abstract inherited private operation&" &
6918                   " must be overridden (RM 3.9.3(10))",
6919                  Parent (Typ), Prim);
6920             end if;
6921          end if;
6922
6923          Next_Elmt (Prim_Elmt);
6924       end loop;
6925
6926       --  Additional check
6927
6928       if Is_Controlled (Typ) then
6929          if not Finalized then
6930             Error_Msg_N
6931               ("controlled type has no explicit Finalize method?", Typ);
6932
6933          elsif not Adjusted then
6934             Error_Msg_N
6935               ("controlled type has no explicit Adjust method?", Typ);
6936          end if;
6937       end if;
6938
6939       --  Set the final size of the Dispatch Table
6940
6941       Set_DT_Entry_Count (The_Tag, UI_From_Int (DT_Length));
6942
6943       --  The derived type must have at least as many components as its parent
6944       --  (for root types Etype points to itself and the test cannot fail).
6945
6946       if DT_Entry_Count (The_Tag) <
6947            DT_Entry_Count (First_Tag_Component (Parent_Typ))
6948       then
6949          raise Program_Error;
6950       end if;
6951    end Set_All_DT_Position;
6952
6953    -----------------------------
6954    -- Set_Default_Constructor --
6955    -----------------------------
6956
6957    procedure Set_Default_Constructor (Typ : Entity_Id) is
6958       Loc   : Source_Ptr;
6959       Init  : Entity_Id;
6960       Param : Entity_Id;
6961       E     : Entity_Id;
6962
6963    begin
6964       --  Look for the default constructor entity. For now only the
6965       --  default constructor has the flag Is_Constructor.
6966
6967       E := Next_Entity (Typ);
6968       while Present (E)
6969         and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
6970       loop
6971          Next_Entity (E);
6972       end loop;
6973
6974       --  Create the init procedure
6975
6976       if Present (E) then
6977          Loc   := Sloc (E);
6978          Init  := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
6979          Param := Make_Defining_Identifier (Loc, Name_X);
6980
6981          Discard_Node (
6982            Make_Subprogram_Declaration (Loc,
6983              Make_Procedure_Specification (Loc,
6984                Defining_Unit_Name => Init,
6985                Parameter_Specifications => New_List (
6986                  Make_Parameter_Specification (Loc,
6987                    Defining_Identifier => Param,
6988                    Parameter_Type      => New_Reference_To (Typ, Loc))))));
6989
6990          Set_Init_Proc (Typ, Init);
6991          Set_Is_Imported    (Init);
6992          Set_Interface_Name (Init, Interface_Name (E));
6993          Set_Convention     (Init, Convention_C);
6994          Set_Is_Public      (Init);
6995          Set_Has_Completion (Init);
6996
6997       --  If there are no constructors, mark the type as abstract since we
6998       --  won't be able to declare objects of that type.
6999
7000       else
7001          Set_Is_Abstract_Type (Typ);
7002       end if;
7003    end Set_Default_Constructor;
7004
7005    --------------------------
7006    -- Set_DTC_Entity_Value --
7007    --------------------------
7008
7009    procedure Set_DTC_Entity_Value
7010      (Tagged_Type : Entity_Id;
7011       Prim        : Entity_Id)
7012    is
7013    begin
7014       if Present (Interface_Alias (Prim))
7015         and then Is_Interface
7016                    (Find_Dispatching_Type (Interface_Alias (Prim)))
7017       then
7018          Set_DTC_Entity (Prim,
7019            Find_Interface_Tag
7020              (T     => Tagged_Type,
7021               Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
7022       else
7023          Set_DTC_Entity (Prim,
7024            First_Tag_Component (Tagged_Type));
7025       end if;
7026    end Set_DTC_Entity_Value;
7027
7028    -----------------
7029    -- Tagged_Kind --
7030    -----------------
7031
7032    function Tagged_Kind (T : Entity_Id) return Node_Id is
7033       Conc_Typ : Entity_Id;
7034       Loc      : constant Source_Ptr := Sloc (T);
7035
7036    begin
7037       pragma Assert
7038         (Is_Tagged_Type (T) and then RTE_Available (RE_Tagged_Kind));
7039
7040       --  Abstract kinds
7041
7042       if Is_Abstract_Type (T) then
7043          if Is_Limited_Record (T) then
7044             return New_Reference_To (RTE (RE_TK_Abstract_Limited_Tagged), Loc);
7045          else
7046             return New_Reference_To (RTE (RE_TK_Abstract_Tagged), Loc);
7047          end if;
7048
7049       --  Concurrent kinds
7050
7051       elsif Is_Concurrent_Record_Type (T) then
7052          Conc_Typ := Corresponding_Concurrent_Type (T);
7053
7054          if Present (Full_View (Conc_Typ)) then
7055             Conc_Typ := Full_View (Conc_Typ);
7056          end if;
7057
7058          if Ekind (Conc_Typ) = E_Protected_Type then
7059             return New_Reference_To (RTE (RE_TK_Protected), Loc);
7060          else
7061             pragma Assert (Ekind (Conc_Typ) = E_Task_Type);
7062             return New_Reference_To (RTE (RE_TK_Task), Loc);
7063          end if;
7064
7065       --  Regular tagged kinds
7066
7067       else
7068          if Is_Limited_Record (T) then
7069             return New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc);
7070          else
7071             return New_Reference_To (RTE (RE_TK_Tagged), Loc);
7072          end if;
7073       end if;
7074    end Tagged_Kind;
7075
7076    --------------
7077    -- Write_DT --
7078    --------------
7079
7080    procedure Write_DT (Typ : Entity_Id) is
7081       Elmt : Elmt_Id;
7082       Prim : Node_Id;
7083
7084    begin
7085       --  Protect this procedure against wrong usage. Required because it will
7086       --  be used directly from GDB
7087
7088       if not (Typ <= Last_Node_Id)
7089         or else not Is_Tagged_Type (Typ)
7090       then
7091          Write_Str ("wrong usage: Write_DT must be used with tagged types");
7092          Write_Eol;
7093          return;
7094       end if;
7095
7096       Write_Int (Int (Typ));
7097       Write_Str (": ");
7098       Write_Name (Chars (Typ));
7099
7100       if Is_Interface (Typ) then
7101          Write_Str (" is interface");
7102       end if;
7103
7104       Write_Eol;
7105
7106       Elmt := First_Elmt (Primitive_Operations (Typ));
7107       while Present (Elmt) loop
7108          Prim := Node (Elmt);
7109          Write_Str  (" - ");
7110
7111          --  Indicate if this primitive will be allocated in the primary
7112          --  dispatch table or in a secondary dispatch table associated
7113          --  with an abstract interface type
7114
7115          if Present (DTC_Entity (Prim)) then
7116             if Etype (DTC_Entity (Prim)) = RTE (RE_Tag) then
7117                Write_Str ("[P] ");
7118             else
7119                Write_Str ("[s] ");
7120             end if;
7121          end if;
7122
7123          --  Output the node of this primitive operation and its name
7124
7125          Write_Int  (Int (Prim));
7126          Write_Str  (": ");
7127
7128          if Is_Predefined_Dispatching_Operation (Prim) then
7129             Write_Str ("(predefined) ");
7130          end if;
7131
7132          Write_Name (Chars (Prim));
7133
7134          --  Indicate if this primitive has an aliased primitive
7135
7136          if Present (Alias (Prim)) then
7137             Write_Str (" (alias = ");
7138             Write_Int (Int (Alias (Prim)));
7139
7140             --  If the DTC_Entity attribute is already set we can also output
7141             --  the name of the interface covered by this primitive (if any)
7142
7143             if Present (DTC_Entity (Alias (Prim)))
7144               and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
7145             then
7146                Write_Str  (" from interface ");
7147                Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
7148             end if;
7149
7150             if Present (Interface_Alias (Prim)) then
7151                Write_Str  (", AI_Alias of ");
7152                Write_Name
7153                  (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
7154                Write_Char (':');
7155                Write_Int  (Int (Interface_Alias (Prim)));
7156             end if;
7157
7158             Write_Str (")");
7159          end if;
7160
7161          --  Display the final position of this primitive in its associated
7162          --  (primary or secondary) dispatch table
7163
7164          if Present (DTC_Entity (Prim))
7165            and then DT_Position (Prim) /= No_Uint
7166          then
7167             Write_Str (" at #");
7168             Write_Int (UI_To_Int (DT_Position (Prim)));
7169          end if;
7170
7171          if Is_Abstract_Subprogram (Prim) then
7172             Write_Str (" is abstract;");
7173
7174          --  Check if this is a null primitive
7175
7176          elsif Comes_From_Source (Prim)
7177            and then Ekind (Prim) = E_Procedure
7178            and then Null_Present (Parent (Prim))
7179          then
7180             Write_Str (" is null;");
7181          end if;
7182
7183          Write_Eol;
7184
7185          Next_Elmt (Elmt);
7186       end loop;
7187    end Write_DT;
7188
7189 end Exp_Disp;