gcc/ada/exp_disp.adb

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