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-2005 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Ch7;  use Exp_Ch7;
  33 with Exp_Tss;  use Exp_Tss;
  34 with Exp_Util; use Exp_Util;
  35 with Fname;    use Fname;
  36 with Itypes;   use Itypes;
  37 with Lib;      use Lib;
  38 with Nlists;   use Nlists;
  39 with Nmake;    use Nmake;
  40 with Opt;      use Opt;
  41 with Rtsfind;  use Rtsfind;
  42 with Sem_Disp; use Sem_Disp;
  43 with Sem_Res;  use Sem_Res;
  44 with Sem_Util; use Sem_Util;
  45 with Sinfo;    use Sinfo;
  46 with Snames;   use Snames;
  47 with Stand;    use Stand;
  48 with Tbuild;   use Tbuild;
  49 with Uintp;    use Uintp;
  50
  51 package body Exp_Disp is
  52
  53    Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
  54       (CW_Membership           => RE_CW_Membership,
  55        DT_Entry_Size           => RE_DT_Entry_Size,
  56        DT_Prologue_Size        => RE_DT_Prologue_Size,
  57        Get_External_Tag        => RE_Get_External_Tag,
  58        Get_Prim_Op_Address     => RE_Get_Prim_Op_Address,
  59        Get_RC_Offset           => RE_Get_RC_Offset,
  60        Get_Remotely_Callable   => RE_Get_Remotely_Callable,
  61        Get_TSD                 => RE_Get_TSD,
  62        Inherit_DT              => RE_Inherit_DT,
  63        Inherit_TSD             => RE_Inherit_TSD,
  64        Register_Tag            => RE_Register_Tag,
  65        Set_Expanded_Name       => RE_Set_Expanded_Name,
  66        Set_External_Tag        => RE_Set_External_Tag,
  67        Set_Prim_Op_Address     => RE_Set_Prim_Op_Address,
  68        Set_RC_Offset           => RE_Set_RC_Offset,
  69        Set_Remotely_Callable   => RE_Set_Remotely_Callable,
  70        Set_TSD                 => RE_Set_TSD,
  71        TSD_Entry_Size          => RE_TSD_Entry_Size,
  72        TSD_Prologue_Size       => RE_TSD_Prologue_Size);
  73
  74    CPP_Actions : constant array (DT_Access_Action) of RE_Id :=
  75       (CW_Membership           => RE_CPP_CW_Membership,
  76        DT_Entry_Size           => RE_CPP_DT_Entry_Size,
  77        DT_Prologue_Size        => RE_CPP_DT_Prologue_Size,
  78        Get_External_Tag        => RE_CPP_Get_External_Tag,
  79        Get_Prim_Op_Address     => RE_CPP_Get_Prim_Op_Address,
  80        Get_RC_Offset           => RE_CPP_Get_RC_Offset,
  81        Get_Remotely_Callable   => RE_CPP_Get_Remotely_Callable,
  82        Get_TSD                 => RE_CPP_Get_TSD,
  83        Inherit_DT              => RE_CPP_Inherit_DT,
  84        Inherit_TSD             => RE_CPP_Inherit_TSD,
  85        Register_Tag            => RE_CPP_Register_Tag,
  86        Set_Expanded_Name       => RE_CPP_Set_Expanded_Name,
  87        Set_External_Tag        => RE_CPP_Set_External_Tag,
  88        Set_Prim_Op_Address     => RE_CPP_Set_Prim_Op_Address,
  89        Set_RC_Offset           => RE_CPP_Set_RC_Offset,
  90        Set_Remotely_Callable   => RE_CPP_Set_Remotely_Callable,
  91        Set_TSD                 => RE_CPP_Set_TSD,
  92        TSD_Entry_Size          => RE_CPP_TSD_Entry_Size,
  93        TSD_Prologue_Size       => RE_CPP_TSD_Prologue_Size);
  94
  95    Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
  96       (CW_Membership           => False,
  97        DT_Entry_Size           => False,
  98        DT_Prologue_Size        => False,
  99        Get_External_Tag        => False,
 100        Get_Prim_Op_Address     => False,
 101        Get_Remotely_Callable   => False,
 102        Get_RC_Offset           => False,
 103        Get_TSD                 => False,
 104        Inherit_DT              => True,
 105        Inherit_TSD             => True,
 106        Register_Tag            => True,
 107        Set_Expanded_Name       => True,
 108        Set_External_Tag        => True,
 109        Set_Prim_Op_Address     => True,
 110        Set_RC_Offset           => True,
 111        Set_Remotely_Callable   => True,
 112        Set_TSD                 => True,
 113        TSD_Entry_Size          => False,
 114        TSD_Prologue_Size       => False);
 115
 116    Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
 117       (CW_Membership           => 2,
 118        DT_Entry_Size           => 0,
 119        DT_Prologue_Size        => 0,
 120        Get_External_Tag        => 1,
 121        Get_Prim_Op_Address     => 2,
 122        Get_RC_Offset           => 1,
 123        Get_Remotely_Callable   => 1,
 124        Get_TSD                 => 1,
 125        Inherit_DT              => 3,
 126        Inherit_TSD             => 2,
 127        Register_Tag            => 1,
 128        Set_Expanded_Name       => 2,
 129        Set_External_Tag        => 2,
 130        Set_Prim_Op_Address     => 3,
 131        Set_RC_Offset           => 2,
 132        Set_Remotely_Callable   => 2,
 133        Set_TSD                 => 2,
 134        TSD_Entry_Size          => 0,
 135        TSD_Prologue_Size       => 0);
 136
 137    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
 138    --  Check if the type has a private view or if the public view appears
 139    --  in the visible part of a package spec.
 140
 141    -----------------------------
 142    -- Expand_Dispatching_Call --
 143    -----------------------------
 144
 145    procedure Expand_Dispatching_Call (Call_Node : Node_Id) is
 146       Loc      : constant Source_Ptr := Sloc (Call_Node);
 147       Call_Typ : constant Entity_Id  := Etype (Call_Node);
 148
 149       Ctrl_Arg   : constant Node_Id := Controlling_Argument (Call_Node);
 150       Param_List : constant List_Id := Parameter_Associations (Call_Node);
 151       Subp       : Entity_Id        := Entity (Name (Call_Node));
 152
 153       CW_Typ          : Entity_Id;
 154       New_Call        : Node_Id;
 155       New_Call_Name   : Node_Id;
 156       New_Params      : List_Id := No_List;
 157       Param           : Node_Id;
 158       Res_Typ         : Entity_Id;
 159       Subp_Ptr_Typ    : Entity_Id;
 160       Subp_Typ        : Entity_Id;
 161       Typ             : Entity_Id;
 162       Eq_Prim_Op      : Entity_Id := Empty;
 163       Controlling_Tag : Node_Id;
 164
 165       function New_Value (From : Node_Id) return Node_Id;
 166       --  From is the original Expression. New_Value is equivalent to a call
 167       --  to Duplicate_Subexpr with an explicit dereference when From is an
 168       --  access parameter.
 169
 170       function Controlling_Type (Subp : Entity_Id) return Entity_Id;
 171       --  Returns the tagged type for which Subp is a primitive subprogram
 172
 173       ---------------
 174       -- New_Value --
 175       ---------------
 176
 177       function New_Value (From : Node_Id) return Node_Id is
 178          Res : constant Node_Id := Duplicate_Subexpr (From);
 179       begin
 180          if Is_Access_Type (Etype (From)) then
 181             return Make_Explicit_Dereference (Sloc (From), Res);
 182          else
 183             return Res;
 184          end if;
 185       end New_Value;
 186
 187       ----------------------
 188       -- Controlling_Type --
 189       ----------------------
 190
 191       function Controlling_Type (Subp : Entity_Id) return Entity_Id is
 192       begin
 193          if Ekind (Subp) = E_Function
 194            and then Has_Controlling_Result (Subp)
 195          then
 196             return Base_Type (Etype (Subp));
 197
 198          else
 199             declare
 200                Formal : Entity_Id := First_Formal (Subp);
 201
 202             begin
 203                while Present (Formal) loop
 204                   if Is_Controlling_Formal (Formal) then
 205                      if Is_Access_Type (Etype (Formal)) then
 206                         return Base_Type (Designated_Type (Etype (Formal)));
 207                      else
 208                         return Base_Type (Etype (Formal));
 209                      end if;
 210                   end if;
 211
 212                   Next_Formal (Formal);
 213                end loop;
 214             end;
 215          end if;
 216
 217          --  Controlling type not found (should never happen)
 218
 219          return Empty;
 220       end Controlling_Type;
 221
 222    --  Start of processing for Expand_Dispatching_Call
 223
 224    begin
 225       --  If this is an inherited operation that was overridden, the body
 226       --  that is being called is its alias.
 227
 228       if Present (Alias (Subp))
 229         and then Is_Inherited_Operation (Subp)
 230         and then No (DTC_Entity (Subp))
 231       then
 232          Subp := Alias (Subp);
 233       end if;
 234
 235       --  Expand_Dispatching_Call is called directly from the semantics,
 236       --  so we need a check to see whether expansion is active before
 237       --  proceeding.
 238
 239       if not Expander_Active then
 240          return;
 241       end if;
 242
 243       --  Definition of the class-wide type and the tagged type
 244
 245       --  If the controlling argument is itself a tag rather than a tagged
 246       --  object, then use the class-wide type associated with the subprogram's
 247       --  controlling type. This case can occur when a call to an inherited
 248       --  primitive has an actual that originated from a default parameter
 249       --  given by a tag-indeterminate call and when there is no other
 250       --  controlling argument providing the tag (AI-239 requires dispatching).
 251       --  This capability of dispatching directly by tag is also needed by the
 252       --  implementation of AI-260 (for the generic dispatching constructors).
 253
 254       if Etype (Ctrl_Arg) = RTE (RE_Tag) then
 255          CW_Typ := Class_Wide_Type (Controlling_Type (Subp));
 256
 257       elsif Is_Access_Type (Etype (Ctrl_Arg)) then
 258          CW_Typ := Designated_Type (Etype (Ctrl_Arg));
 259
 260       else
 261          CW_Typ := Etype (Ctrl_Arg);
 262       end if;
 263
 264       Typ := Root_Type (CW_Typ);
 265
 266       if not Is_Limited_Type (Typ) then
 267          Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
 268       end if;
 269
 270       if Is_CPP_Class (Root_Type (Typ)) then
 271
 272          --  Create a new parameter list with the displaced 'this'
 273
 274          New_Params := New_List;
 275          Param := First_Actual (Call_Node);
 276          while Present (Param) loop
 277
 278             --  We assume that dispatching through the main dispatch table
 279             --  (referenced by Tag_Component) doesn't require a displacement
 280             --  so the expansion below is only done when dispatching on
 281             --  another vtable pointer, in which case the first argument
 282             --  is expanded into :
 283
 284             --     typ!(Displaced_This (Address!(Param)))
 285
 286             if Param = Ctrl_Arg
 287               and then DTC_Entity (Subp) /= First_Tag_Component (Typ)
 288             then
 289                Append_To (New_Params,
 290
 291                  Unchecked_Convert_To (Etype (Param),
 292                    Make_Function_Call (Loc,
 293                      Name => New_Reference_To (RTE (RE_Displaced_This), Loc),
 294                      Parameter_Associations => New_List (
 295
 296                      --  Current_This
 297
 298                        Make_Unchecked_Type_Conversion (Loc,
 299                          Subtype_Mark =>
 300                            New_Reference_To (RTE (RE_Address), Loc),
 301                          Expression   => Relocate_Node (Param)),
 302
 303                      --  Vptr
 304
 305                        Make_Selected_Component (Loc,
 306                           Prefix => Duplicate_Subexpr (Ctrl_Arg),
 307                           Selector_Name =>
 308                             New_Reference_To (DTC_Entity (Subp), Loc)),
 309
 310                      --  Position
 311
 312                        Make_Integer_Literal (Loc, DT_Position (Subp))))));
 313
 314             else
 315                Append_To (New_Params, Relocate_Node (Param));
 316             end if;
 317
 318             Next_Actual (Param);
 319          end loop;
 320
 321       elsif Present (Param_List) then
 322
 323          --  Generate the Tag checks when appropriate
 324
 325          New_Params := New_List;
 326
 327          Param := First_Actual (Call_Node);
 328          while Present (Param) loop
 329
 330             --  No tag check with itself
 331
 332             if Param = Ctrl_Arg then
 333                Append_To (New_Params,
 334                  Duplicate_Subexpr_Move_Checks (Param));
 335
 336             --  No tag check for parameter whose type is neither tagged nor
 337             --  access to tagged (for access parameters)
 338
 339             elsif No (Find_Controlling_Arg (Param)) then
 340                Append_To (New_Params, Relocate_Node (Param));
 341
 342             --  No tag check for function dispatching on result if the
 343             --  Tag given by the context is this one
 344
 345             elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
 346                Append_To (New_Params, Relocate_Node (Param));
 347
 348             --  "=" is the only dispatching operation allowed to get
 349             --  operands with incompatible tags (it just returns false).
 350             --  We use Duplicate_Subexpr_Move_Checks instead of calling
 351             --  Relocate_Node because the value will be duplicated to
 352             --  check the tags.
 353
 354             elsif Subp = Eq_Prim_Op then
 355                Append_To (New_Params,
 356                  Duplicate_Subexpr_Move_Checks (Param));
 357
 358             --  No check in presence of suppress flags
 359
 360             elsif Tag_Checks_Suppressed (Etype (Param))
 361               or else (Is_Access_Type (Etype (Param))
 362                          and then Tag_Checks_Suppressed
 363                                     (Designated_Type (Etype (Param))))
 364             then
 365                Append_To (New_Params, Relocate_Node (Param));
 366
 367             --  Optimization: no tag checks if the parameters are identical
 368
 369             elsif Is_Entity_Name (Param)
 370               and then Is_Entity_Name (Ctrl_Arg)
 371               and then Entity (Param) = Entity (Ctrl_Arg)
 372             then
 373                Append_To (New_Params, Relocate_Node (Param));
 374
 375             --  Now we need to generate the Tag check
 376
 377             else
 378                --  Generate code for tag equality check
 379                --  Perhaps should have Checks.Apply_Tag_Equality_Check???
 380
 381                Insert_Action (Ctrl_Arg,
 382                  Make_Implicit_If_Statement (Call_Node,
 383                    Condition =>
 384                      Make_Op_Ne (Loc,
 385                        Left_Opnd =>
 386                          Make_Selected_Component (Loc,
 387                            Prefix => New_Value (Ctrl_Arg),
 388                            Selector_Name =>
 389                              New_Reference_To
 390                                (First_Tag_Component (Typ), Loc)),
 391
 392                        Right_Opnd =>
 393                          Make_Selected_Component (Loc,
 394                            Prefix =>
 395                              Unchecked_Convert_To (Typ, New_Value (Param)),
 396                            Selector_Name =>
 397                              New_Reference_To
 398                                (First_Tag_Component (Typ), Loc))),
 399
 400                    Then_Statements =>
 401                      New_List (New_Constraint_Error (Loc))));
 402
 403                Append_To (New_Params, Relocate_Node (Param));
 404             end if;
 405
 406             Next_Actual (Param);
 407          end loop;
 408       end if;
 409
 410       --  Generate the appropriate subprogram pointer type
 411
 412       if  Etype (Subp) = Typ then
 413          Res_Typ := CW_Typ;
 414       else
 415          Res_Typ := Etype (Subp);
 416       end if;
 417
 418       Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
 419       Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
 420       Set_Etype          (Subp_Typ, Res_Typ);
 421       Init_Size_Align    (Subp_Ptr_Typ);
 422       Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
 423
 424       --  Create a new list of parameters which is a copy of the old formal
 425       --  list including the creation of a new set of matching entities.
 426
 427       declare
 428          Old_Formal : Entity_Id := First_Formal (Subp);
 429          New_Formal : Entity_Id;
 430          Extra      : Entity_Id;
 431
 432       begin
 433          if Present (Old_Formal) then
 434             New_Formal := New_Copy (Old_Formal);
 435             Set_First_Entity (Subp_Typ, New_Formal);
 436             Param := First_Actual (Call_Node);
 437
 438             loop
 439                Set_Scope (New_Formal, Subp_Typ);
 440
 441                --  Change all the controlling argument types to be class-wide
 442                --  to avoid a recursion in dispatching.
 443
 444                if Is_Controlling_Formal (New_Formal) then
 445                   Set_Etype (New_Formal, Etype (Param));
 446                end if;
 447
 448                if Is_Itype (Etype (New_Formal)) then
 449                   Extra := New_Copy (Etype (New_Formal));
 450
 451                   if Ekind (Extra) = E_Record_Subtype
 452                     or else Ekind (Extra) = E_Class_Wide_Subtype
 453                   then
 454                      Set_Cloned_Subtype (Extra, Etype (New_Formal));
 455                   end if;
 456
 457                   Set_Etype (New_Formal, Extra);
 458                   Set_Scope (Etype (New_Formal), Subp_Typ);
 459                end if;
 460
 461                Extra := New_Formal;
 462                Next_Formal (Old_Formal);
 463                exit when No (Old_Formal);
 464
 465                Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
 466                Next_Entity (New_Formal);
 467                Next_Actual (Param);
 468             end loop;
 469             Set_Last_Entity (Subp_Typ, Extra);
 470
 471             --  Copy extra formals
 472
 473             New_Formal := First_Entity (Subp_Typ);
 474             while Present (New_Formal) loop
 475                if Present (Extra_Constrained (New_Formal)) then
 476                   Set_Extra_Formal (Extra,
 477                     New_Copy (Extra_Constrained (New_Formal)));
 478                   Extra := Extra_Formal (Extra);
 479                   Set_Extra_Constrained (New_Formal, Extra);
 480
 481                elsif Present (Extra_Accessibility (New_Formal)) then
 482                   Set_Extra_Formal (Extra,
 483                     New_Copy (Extra_Accessibility (New_Formal)));
 484                   Extra := Extra_Formal (Extra);
 485                   Set_Extra_Accessibility (New_Formal, Extra);
 486                end if;
 487
 488                Next_Formal (New_Formal);
 489             end loop;
 490          end if;
 491       end;
 492
 493       Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
 494       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
 495
 496       --  If the controlling argument is a value of type Ada.Tag then
 497       --  use it directly.  Otherwise, the tag must be extracted from
 498       --  the controlling object.
 499
 500       if Etype (Ctrl_Arg) = RTE (RE_Tag) then
 501          Controlling_Tag := Duplicate_Subexpr (Ctrl_Arg);
 502
 503       else
 504          Controlling_Tag :=
 505            Make_Selected_Component (Loc,
 506              Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
 507              Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc));
 508       end if;
 509
 510       --  Generate:
 511       --   Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
 512
 513       New_Call_Name :=
 514         Unchecked_Convert_To (Subp_Ptr_Typ,
 515           Make_DT_Access_Action (Typ,
 516             Action => Get_Prim_Op_Address,
 517             Args => New_List (
 518
 519             --  Vptr
 520
 521               Controlling_Tag,
 522
 523             --  Position
 524
 525               Make_Integer_Literal (Loc, DT_Position (Subp)))));
 526
 527       if Nkind (Call_Node) = N_Function_Call then
 528          New_Call :=
 529            Make_Function_Call (Loc,
 530              Name => New_Call_Name,
 531              Parameter_Associations => New_Params);
 532
 533          --  If this is a dispatching "=", we must first compare the tags so
 534          --  we generate: x.tag = y.tag and then x = y
 535
 536          if Subp = Eq_Prim_Op then
 537             Param := First_Actual (Call_Node);
 538             New_Call :=
 539               Make_And_Then (Loc,
 540                 Left_Opnd =>
 541                      Make_Op_Eq (Loc,
 542                        Left_Opnd =>
 543                          Make_Selected_Component (Loc,
 544                            Prefix => New_Value (Param),
 545                            Selector_Name =>
 546                              New_Reference_To
 547                                (First_Tag_Component (Typ), Loc)),
 548
 549                        Right_Opnd =>
 550                          Make_Selected_Component (Loc,
 551                            Prefix =>
 552                              Unchecked_Convert_To (Typ,
 553                                New_Value (Next_Actual (Param))),
 554                            Selector_Name =>
 555                              New_Reference_To
 556                                (First_Tag_Component (Typ), Loc))),
 557
 558                 Right_Opnd => New_Call);
 559          end if;
 560
 561       else
 562          New_Call :=
 563            Make_Procedure_Call_Statement (Loc,
 564              Name => New_Call_Name,
 565              Parameter_Associations => New_Params);
 566       end if;
 567
 568       Rewrite (Call_Node, New_Call);
 569       Analyze_And_Resolve (Call_Node, Call_Typ);
 570    end Expand_Dispatching_Call;
 571
 572    -------------
 573    -- Fill_DT --
 574    -------------
 575
 576    function Fill_DT_Entry
 577      (Loc  : Source_Ptr;
 578       Prim : Entity_Id)
 579       return Node_Id
 580    is
 581       Typ    : constant Entity_Id := Scope (DTC_Entity (Prim));
 582       DT_Ptr : constant Entity_Id := Node (First_Elmt
 583                                            (Access_Disp_Table (Typ)));
 584
 585    begin
 586       return
 587         Make_DT_Access_Action (Typ,
 588           Action => Set_Prim_Op_Address,
 589           Args   => New_List (
 590             New_Reference_To (DT_Ptr, Loc),                     -- DTptr
 591
 592             Make_Integer_Literal (Loc, DT_Position (Prim)),     -- Position
 593
 594             Make_Attribute_Reference (Loc,                      -- Value
 595               Prefix          => New_Reference_To (Prim, Loc),
 596               Attribute_Name  => Name_Address)));
 597    end Fill_DT_Entry;
 598
 599    ---------------------------
 600    -- Get_Remotely_Callable --
 601    ---------------------------
 602
 603    function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
 604       Loc : constant Source_Ptr := Sloc (Obj);
 605
 606    begin
 607       return Make_DT_Access_Action
 608         (Typ    => Etype (Obj),
 609          Action => Get_Remotely_Callable,
 610          Args   => New_List (
 611            Make_Selected_Component (Loc,
 612              Prefix        => Obj,
 613              Selector_Name => Make_Identifier (Loc, Name_uTag))));
 614    end Get_Remotely_Callable;
 615
 616    -------------
 617    -- Make_DT --
 618    -------------
 619
 620    function Make_DT (Typ : Entity_Id) return List_Id is
 621       Loc : constant Source_Ptr := Sloc (Typ);
 622
 623       ADT_List  : constant Elist_Id := New_Elmt_List;
 624       Result    : constant List_Id  := New_List;
 625       Elab_Code : constant List_Id  := New_List;
 626
 627       Tname       : constant Name_Id := Chars (Typ);
 628       Name_DT     : constant Name_Id := New_External_Name (Tname, 'T');
 629       Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
 630       Name_TSD    : constant Name_Id := New_External_Name (Tname, 'B');
 631       Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
 632       Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
 633
 634       DT     : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
 635       DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
 636       TSD    : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
 637       Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
 638       No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
 639
 640       I_Depth         : Int;
 641       Generalized_Tag : Entity_Id;
 642       Size_Expr_Node  : Node_Id;
 643       Old_Tag         : Node_Id;
 644       Old_TSD         : Node_Id;
 645
 646    begin
 647       if not RTE_Available (RE_Tag) then
 648          Error_Msg_CRT ("tagged types", Typ);
 649          return New_List;
 650       end if;
 651
 652       if Is_CPP_Class (Root_Type (Typ)) then
 653          Generalized_Tag := RTE (RE_Vtable_Ptr);
 654       else
 655          Generalized_Tag := RTE (RE_Tag);
 656       end if;
 657
 658       --  Dispatch table and related entities are allocated statically
 659
 660       Set_Ekind (DT, E_Variable);
 661       Set_Is_Statically_Allocated (DT);
 662
 663       Set_Ekind (DT_Ptr, E_Variable);
 664       Set_Is_Statically_Allocated (DT_Ptr);
 665
 666       Set_Ekind (TSD, E_Variable);
 667       Set_Is_Statically_Allocated (TSD);
 668
 669       Set_Ekind (Exname, E_Variable);
 670       Set_Is_Statically_Allocated (Exname);
 671
 672       Set_Ekind (No_Reg, E_Variable);
 673       Set_Is_Statically_Allocated (No_Reg);
 674
 675       --  Generate code to create the storage for the Dispatch_Table object:
 676
 677       --   DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
 678       --   for DT'Alignment use Address'Alignment
 679
 680       Size_Expr_Node :=
 681         Make_Op_Add (Loc,
 682           Left_Opnd  => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
 683           Right_Opnd =>
 684             Make_Op_Multiply (Loc,
 685               Left_Opnd  =>
 686                 Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
 687               Right_Opnd =>
 688                 Make_Integer_Literal (Loc,
 689                   DT_Entry_Count (First_Tag_Component (Typ)))));
 690
 691       Append_To (Result,
 692         Make_Object_Declaration (Loc,
 693           Defining_Identifier => DT,
 694           Aliased_Present     => True,
 695           Object_Definition   =>
 696             Make_Subtype_Indication (Loc,
 697               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
 698               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
 699                 Constraints => New_List (
 700                   Make_Range (Loc,
 701                     Low_Bound  => Make_Integer_Literal (Loc, 1),
 702                     High_Bound => Size_Expr_Node))))));
 703
 704       Append_To (Result,
 705         Make_Attribute_Definition_Clause (Loc,
 706           Name       => New_Reference_To (DT, Loc),
 707           Chars      => Name_Alignment,
 708           Expression =>
 709             Make_Attribute_Reference (Loc,
 710               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
 711               Attribute_Name => Name_Alignment)));
 712
 713       --  Generate code to create the pointer to the dispatch table
 714
 715       --    DT_Ptr : Tag := Tag!(DT'Address);                 Ada case
 716       --  or
 717       --    DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address);   CPP case
 718
 719       --  According to the C++ ABI, the base of the vtable is located
 720       --  after the following prologue: Offset_To_Top, Typeinfo_Ptr.
 721       --  Hence, move the pointer to the base of the vtable down, after
 722       --  this prologue.
 723
 724       Append_To (Result,
 725         Make_Object_Declaration (Loc,
 726           Defining_Identifier => DT_Ptr,
 727           Constant_Present    => True,
 728           Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
 729           Expression          =>
 730             Unchecked_Convert_To (Generalized_Tag,
 731               Make_Op_Add (Loc,
 732                 Left_Opnd =>
 733                   Unchecked_Convert_To (RTE (RE_Storage_Offset),
 734                     Make_Attribute_Reference (Loc,
 735                       Prefix         => New_Reference_To (DT, Loc),
 736                       Attribute_Name => Name_Address)),
 737                 Right_Opnd =>
 738                   Make_DT_Access_Action (Typ,
 739                     DT_Prologue_Size, No_List)))));
 740
 741       --  Generate code to define the boolean that controls registration, in
 742       --  order to avoid multiple registrations for tagged types defined in
 743       --  multiple-called scopes
 744
 745       Append_To (Result,
 746         Make_Object_Declaration (Loc,
 747           Defining_Identifier => No_Reg,
 748           Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
 749           Expression          => New_Reference_To (Standard_True, Loc)));
 750
 751       --  Set Access_Disp_Table field to be the dispatch table pointer
 752
 753       Append_Elmt (DT_Ptr, ADT_List);
 754       Set_Access_Disp_Table (Typ, ADT_List);
 755
 756       --  Count ancestors to compute the inheritance depth. For private
 757       --  extensions, always go to the full view in order to compute the real
 758       --  inheritance depth.
 759
 760       declare
 761          Parent_Type : Entity_Id := Typ;
 762          P           : Entity_Id;
 763
 764       begin
 765          I_Depth := 0;
 766
 767          loop
 768             P := Etype (Parent_Type);
 769
 770             if Is_Private_Type (P) then
 771                P := Full_View (Base_Type (P));
 772             end if;
 773
 774             exit when P = Parent_Type;
 775
 776             I_Depth := I_Depth + 1;
 777             Parent_Type := P;
 778          end loop;
 779       end;
 780
 781       --  Generate code to create the storage for the type specific data object
 782
 783       --   TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size);
 784       --   for TSD'Alignment use Address'Alignment
 785
 786       Size_Expr_Node :=
 787         Make_Op_Add (Loc,
 788           Left_Opnd  =>
 789             Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
 790           Right_Opnd =>
 791             Make_Op_Multiply (Loc,
 792               Left_Opnd  =>
 793                 Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
 794               Right_Opnd =>
 795                 Make_Op_Add (Loc,
 796                   Left_Opnd  => Make_Integer_Literal (Loc, 1),
 797                   Right_Opnd =>
 798                     Make_Integer_Literal (Loc, I_Depth))));
 799
 800       Append_To (Result,
 801         Make_Object_Declaration (Loc,
 802           Defining_Identifier => TSD,
 803           Aliased_Present     => True,
 804           Object_Definition   =>
 805             Make_Subtype_Indication (Loc,
 806               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
 807               Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
 808                 Constraints => New_List (
 809                   Make_Range (Loc,
 810                     Low_Bound  => Make_Integer_Literal (Loc, 1),
 811                     High_Bound => Size_Expr_Node))))));
 812
 813       Append_To (Result,
 814         Make_Attribute_Definition_Clause (Loc,
 815           Name       => New_Reference_To (TSD, Loc),
 816           Chars      => Name_Alignment,
 817           Expression =>
 818             Make_Attribute_Reference (Loc,
 819               Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
 820               Attribute_Name => Name_Alignment)));
 821
 822       --  Generate code to put the Address of the TSD in the dispatch table
 823       --    Set_TSD (DT_Ptr, TSD);
 824
 825       Append_To (Elab_Code,
 826         Make_DT_Access_Action (Typ,
 827           Action => Set_TSD,
 828           Args   => New_List (
 829             New_Reference_To (DT_Ptr, Loc),                  -- DTptr
 830               Make_Attribute_Reference (Loc,                 -- Value
 831               Prefix          => New_Reference_To (TSD, Loc),
 832               Attribute_Name  => Name_Address))));
 833
 834       if Typ = Etype (Typ)
 835         or else Is_CPP_Class (Etype (Typ))
 836       then
 837          Old_Tag :=
 838            Unchecked_Convert_To (Generalized_Tag,
 839              Make_Integer_Literal (Loc, 0));
 840
 841          Old_TSD :=
 842            Unchecked_Convert_To (RTE (RE_Address),
 843              Make_Integer_Literal (Loc, 0));
 844
 845       else
 846          Old_Tag :=
 847            New_Reference_To
 848              (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc);
 849          Old_TSD :=
 850            Make_DT_Access_Action (Typ,
 851              Action => Get_TSD,
 852              Args   => New_List (
 853                New_Reference_To
 854                  (Node (First_Elmt (Access_Disp_Table (Etype (Typ)))), Loc)));
 855       end if;
 856
 857       --  Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
 858
 859       Append_To (Elab_Code,
 860         Make_DT_Access_Action (Typ,
 861           Action => Inherit_DT,
 862           Args   => New_List (
 863             Node1 => Old_Tag,
 864             Node2 => New_Reference_To (DT_Ptr, Loc),
 865             Node3 => Make_Integer_Literal (Loc,
 866                        DT_Entry_Count (First_Tag_Component (Etype (Typ)))))));
 867
 868       --  Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr);
 869
 870       Append_To (Elab_Code,
 871         Make_DT_Access_Action (Typ,
 872           Action => Inherit_TSD,
 873           Args   => New_List (
 874             Node1 => Old_TSD,
 875             Node2 => New_Reference_To (DT_Ptr, Loc))));
 876
 877       --  Generate: Exname : constant String := full_qualified_name (typ);
 878       --  The type itself may be an anonymous parent type, so use the first
 879       --  subtype to have a user-recognizable name.
 880
 881       Append_To (Result,
 882         Make_Object_Declaration (Loc,
 883           Defining_Identifier => Exname,
 884           Constant_Present    => True,
 885           Object_Definition   => New_Reference_To (Standard_String, Loc),
 886           Expression =>
 887             Make_String_Literal (Loc,
 888               Full_Qualified_Name (First_Subtype (Typ)))));
 889
 890       --  Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
 891
 892       Append_To (Elab_Code,
 893         Make_DT_Access_Action (Typ,
 894           Action => Set_Expanded_Name,
 895           Args   => New_List (
 896             Node1 => New_Reference_To (DT_Ptr, Loc),
 897             Node2 =>
 898               Make_Attribute_Reference (Loc,
 899                 Prefix => New_Reference_To (Exname, Loc),
 900                 Attribute_Name => Name_Address))));
 901
 902       --  for types with no controlled components
 903       --    Generate: Set_RC_Offset (DT_Ptr, 0);
 904       --  for simple types with controlled components
 905       --    Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position);
 906       --  for complex types with controlled components where the position
 907       --  of the record controller is not statically computable, if there are
 908       --  controlled components at this level
 909       --    Generate: Set_RC_Offset (DT_Ptr, -1);
 910       --  to indicate that the _controller field is right after the _parent or
 911       --  if there are no controlled components at this level,
 912       --    Generate: Set_RC_Offset (DT_Ptr, -2);
 913       --  to indicate that we need to get the position from the parent.
 914
 915       declare
 916          Position : Node_Id;
 917
 918       begin
 919          if not Has_Controlled_Component (Typ) then
 920             Position := Make_Integer_Literal (Loc, 0);
 921
 922          elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then
 923             if Has_New_Controlled_Component (Typ) then
 924                Position := Make_Integer_Literal (Loc, -1);
 925             else
 926                Position := Make_Integer_Literal (Loc, -2);
 927             end if;
 928          else
 929             Position :=
 930               Make_Attribute_Reference (Loc,
 931                 Prefix =>
 932                   Make_Selected_Component (Loc,
 933                     Prefix => New_Reference_To (Typ, Loc),
 934                     Selector_Name =>
 935                       New_Reference_To (Controller_Component (Typ), Loc)),
 936                 Attribute_Name => Name_Position);
 937
 938             --  This is not proper Ada code to use the attribute 'Position
 939             --  on something else than an object but this is supported by
 940             --  the back end (see comment on the Bit_Component attribute in
 941             --  sem_attr). So we avoid semantic checking here.
 942
 943             Set_Analyzed (Position);
 944             Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
 945             Set_Etype (Prefix (Prefix (Position)), Typ);
 946             Set_Etype (Selector_Name (Prefix (Position)),
 947               RTE (RE_Record_Controller));
 948             Set_Etype (Position, RTE (RE_Storage_Offset));
 949          end if;
 950
 951          Append_To (Elab_Code,
 952            Make_DT_Access_Action (Typ,
 953              Action => Set_RC_Offset,
 954              Args   => New_List (
 955                Node1 => New_Reference_To (DT_Ptr, Loc),
 956                Node2 => Position)));
 957       end;
 958
 959       --  Generate: Set_Remotely_Callable (DT_Ptr, Status);
 960       --  where Status is described in E.4 (18)
 961
 962       declare
 963          Status : Entity_Id;
 964
 965       begin
 966          Status :=
 967            Boolean_Literals
 968              (Is_Pure (Typ)
 969                 or else Is_Shared_Passive (Typ)
 970                 or else
 971                   ((Is_Remote_Types (Typ)
 972                       or else Is_Remote_Call_Interface (Typ))
 973                    and then Original_View_In_Visible_Part (Typ))
 974                 or else not Comes_From_Source (Typ));
 975
 976          Append_To (Elab_Code,
 977            Make_DT_Access_Action (Typ,
 978              Action => Set_Remotely_Callable,
 979              Args   => New_List (
 980                New_Occurrence_Of (DT_Ptr, Loc),
 981                New_Occurrence_Of (Status, Loc))));
 982       end;
 983
 984       --  Generate: Set_External_Tag (DT_Ptr, exname'Address);
 985       --  Should be the external name not the qualified name???
 986
 987       if not Has_External_Tag_Rep_Clause (Typ) then
 988          Append_To (Elab_Code,
 989            Make_DT_Access_Action (Typ,
 990              Action => Set_External_Tag,
 991              Args   => New_List (
 992                Node1 => New_Reference_To (DT_Ptr, Loc),
 993                Node2 =>
 994                  Make_Attribute_Reference (Loc,
 995                    Prefix => New_Reference_To (Exname, Loc),
 996                    Attribute_Name => Name_Address))));
 997
 998       --  Generate code to register the Tag in the External_Tag hash
 999       --  table for the pure Ada type only.
1000
1001       --        Register_Tag (Dt_Ptr);
1002
1003       --  Skip this if routine not available, or in No_Run_Time mode
1004
1005          if RTE_Available (RE_Register_Tag)
1006            and then Is_RTE (Generalized_Tag, RE_Tag)
1007            and then not No_Run_Time_Mode
1008          then
1009             Append_To (Elab_Code,
1010               Make_Procedure_Call_Statement (Loc,
1011                 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
1012                 Parameter_Associations =>
1013                   New_List (New_Reference_To (DT_Ptr, Loc))));
1014          end if;
1015       end if;
1016
1017       --  Generate:
1018       --     if No_Reg then
1019       --        <elab_code>
1020       --        No_Reg := False;
1021       --     end if;
1022
1023       Append_To (Elab_Code,
1024         Make_Assignment_Statement (Loc,
1025           Name       => New_Reference_To (No_Reg, Loc),
1026           Expression => New_Reference_To (Standard_False, Loc)));
1027
1028       Append_To (Result,
1029         Make_Implicit_If_Statement (Typ,
1030           Condition       => New_Reference_To (No_Reg, Loc),
1031           Then_Statements => Elab_Code));
1032
1033       return Result;
1034    end Make_DT;
1035
1036    ---------------------------
1037    -- Make_DT_Access_Action --
1038    ---------------------------
1039
1040    function Make_DT_Access_Action
1041      (Typ    : Entity_Id;
1042       Action : DT_Access_Action;
1043       Args   : List_Id)
1044       return Node_Id
1045    is
1046       Action_Name : Entity_Id;
1047       Loc         : Source_Ptr;
1048
1049    begin
1050       if Is_CPP_Class (Root_Type (Typ)) then
1051          Action_Name := RTE (CPP_Actions (Action));
1052       else
1053          Action_Name := RTE (Ada_Actions (Action));
1054       end if;
1055
1056       if No (Args) then
1057
1058          --  This is a constant
1059
1060          return New_Reference_To (Action_Name, Sloc (Typ));
1061       end if;
1062
1063       pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
1064
1065       Loc := Sloc (First (Args));
1066
1067       if Action_Is_Proc (Action) then
1068          return
1069            Make_Procedure_Call_Statement (Loc,
1070              Name => New_Reference_To (Action_Name, Loc),
1071              Parameter_Associations => Args);
1072
1073       else
1074          return
1075            Make_Function_Call (Loc,
1076              Name => New_Reference_To (Action_Name, Loc),
1077              Parameter_Associations => Args);
1078       end if;
1079    end Make_DT_Access_Action;
1080
1081    -----------------------------------
1082    -- Original_View_In_Visible_Part --
1083    -----------------------------------
1084
1085    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
1086       Scop : constant Entity_Id := Scope (Typ);
1087
1088    begin
1089       --  The scope must be a package
1090
1091       if Ekind (Scop) /= E_Package
1092         and then Ekind (Scop) /= E_Generic_Package
1093       then
1094          return False;
1095       end if;
1096
1097       --  A type with a private declaration has a private view declared in
1098       --  the visible part.
1099
1100       if Has_Private_Declaration (Typ) then
1101          return True;
1102       end if;
1103
1104       return List_Containing (Parent (Typ)) =
1105         Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
1106    end Original_View_In_Visible_Part;
1107
1108    -------------------------
1109    -- Set_All_DT_Position --
1110    -------------------------
1111
1112    procedure Set_All_DT_Position (Typ : Entity_Id) is
1113       Parent_Typ : constant Entity_Id := Etype (Typ);
1114       Root_Typ   : constant Entity_Id := Root_Type (Typ);
1115       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
1116       The_Tag    : constant Entity_Id := First_Tag_Component (Typ);
1117       Adjusted   : Boolean := False;
1118       Finalized  : Boolean := False;
1119       Parent_EC  : Int;
1120       Nb_Prim    : Int;
1121       Prim       : Entity_Id;
1122       Prim_Elmt  : Elmt_Id;
1123
1124    begin
1125
1126       --  Get Entry_Count of the parent
1127
1128       if Parent_Typ /= Typ
1129         and then DT_Entry_Count (First_Tag_Component (Parent_Typ)) /= No_Uint
1130       then
1131          Parent_EC := UI_To_Int (DT_Entry_Count
1132                                    (First_Tag_Component (Parent_Typ)));
1133       else
1134          Parent_EC := 0;
1135       end if;
1136
1137       --  C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
1138       --  give a coherent set of information
1139
1140       if Is_CPP_Class (Root_Typ) then
1141
1142          --  Compute the number of primitive operations in the main Vtable
1143          --  Set their position:
1144          --    - where it was set if overriden or inherited
1145          --    - after the end of the parent vtable otherwise
1146
1147          Prim_Elmt := First_Prim;
1148          Nb_Prim := 0;
1149          while Present (Prim_Elmt) loop
1150             Prim := Node (Prim_Elmt);
1151
1152             if not Is_CPP_Class (Typ) then
1153                Set_DTC_Entity (Prim, The_Tag);
1154
1155             elsif Present (Alias (Prim)) then
1156                Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
1157                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
1158
1159             elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
1160                   Error_Msg_NE ("is a primitive operation of&," &
1161                     " pragma Cpp_Virtual required", Prim, Typ);
1162             end if;
1163
1164             if DTC_Entity (Prim) = The_Tag then
1165
1166                --  Get the slot from the parent subprogram if any
1167
1168                declare
1169                   H : Entity_Id := Homonym (Prim);
1170
1171                begin
1172                   while Present (H) loop
1173                      if Present (DTC_Entity (H))
1174                        and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
1175                      then
1176                         Set_DT_Position (Prim, DT_Position (H));
1177                         exit;
1178                      end if;
1179
1180                      H := Homonym (H);
1181                   end loop;
1182                end;
1183
1184                --  Otherwise take the canonical slot after the end of the
1185                --  parent Vtable
1186
1187                if DT_Position (Prim) = No_Uint then
1188                   Nb_Prim := Nb_Prim + 1;
1189                   Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
1190
1191                elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
1192                   Nb_Prim := Nb_Prim + 1;
1193                end if;
1194             end if;
1195
1196             Next_Elmt (Prim_Elmt);
1197          end loop;
1198
1199          --  Check that the declared size of the Vtable is bigger or equal
1200          --  than the number of primitive operations (if bigger it means that
1201          --  some of the c++ virtual functions were not imported, that is
1202          --  allowed)
1203
1204          if DT_Entry_Count (The_Tag) = No_Uint
1205            or else not Is_CPP_Class (Typ)
1206          then
1207             Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
1208
1209          elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
1210             Error_Msg_N ("not enough room in the Vtable for all virtual"
1211               & " functions", The_Tag);
1212          end if;
1213
1214          --  Check that Positions are not duplicate nor outside the range of
1215          --  the Vtable
1216
1217          declare
1218             Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
1219             Pos  : Int;
1220             Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
1221                                                         (others => Empty);
1222
1223          begin
1224             Prim_Elmt := First_Prim;
1225             while Present (Prim_Elmt) loop
1226                Prim := Node (Prim_Elmt);
1227
1228                if DTC_Entity (Prim) = The_Tag then
1229                   Pos := UI_To_Int (DT_Position (Prim));
1230
1231                   if Pos not in Prim_Pos_Table'Range then
1232                      Error_Msg_N
1233                        ("position not in range of virtual table", Prim);
1234
1235                   elsif Present (Prim_Pos_Table (Pos)) then
1236                      Error_Msg_NE ("cannot be at the same position in the"
1237                        & " vtable than&", Prim, Prim_Pos_Table (Pos));
1238
1239                   else
1240                      Prim_Pos_Table (Pos) := Prim;
1241                   end if;
1242                end if;
1243
1244                Next_Elmt (Prim_Elmt);
1245             end loop;
1246          end;
1247
1248       --  For regular Ada tagged types, just set the DT_Position for
1249       --  each primitive operation. Perform some sanity checks to avoid
1250       --  to build completely inconsistant dispatch tables.
1251
1252       --  Note that the _Size primitive is always set at position 1 in order
1253       --  to comply with the needs of Ada.Tags.Parent_Size (see documentation
1254       --  in a-tags.ad?)
1255
1256       else
1257          Nb_Prim := 1;
1258          Prim_Elmt := First_Prim;
1259          while Present (Prim_Elmt) loop
1260             Nb_Prim := Nb_Prim + 1;
1261             Prim := Node (Prim_Elmt);
1262             Set_DTC_Entity (Prim, The_Tag);
1263
1264             if Chars (Prim) = Name_uSize then
1265                Set_DT_Position (Prim, Uint_1);
1266                Nb_Prim := Nb_Prim - 1;
1267             else
1268                Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
1269             end if;
1270
1271             if Chars (Prim) = Name_Finalize
1272               and then
1273                 (Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
1274                    or else not Is_Predefined_File_Name
1275                                   (Unit_File_Name (Get_Source_Unit (Prim))))
1276             then
1277                Finalized := True;
1278             end if;
1279
1280             if Chars (Prim) = Name_Adjust then
1281                Adjusted := True;
1282             end if;
1283
1284             --  An abstract operation cannot be declared in the private part
1285             --  for a visible abstract type, because it could never be over-
1286             --  ridden. For explicit declarations this is checked at the point
1287             --  of declaration, but for inherited operations it must be done
1288             --  when building the dispatch table. Input is excluded because
1289
1290             if Is_Abstract (Typ)
1291               and then Is_Abstract (Prim)
1292               and then Present (Alias (Prim))
1293               and then Is_Derived_Type (Typ)
1294               and then In_Private_Part (Current_Scope)
1295               and then List_Containing (Parent (Prim))
1296                =  Private_Declarations
1297                    (Specification (Unit_Declaration_Node (Current_Scope)))
1298               and then Original_View_In_Visible_Part (Typ)
1299             then
1300                --  We exclude Input and Output stream operations because
1301                --  Limited_Controlled inherits useless Input and Output
1302                --  stream operations from Root_Controlled, which can
1303                --  never be overridden.
1304
1305                if not Is_TSS (Prim, TSS_Stream_Input)
1306                     and then
1307                   not Is_TSS (Prim, TSS_Stream_Output)
1308                then
1309                   Error_Msg_NE
1310                     ("abstract inherited private operation&" &
1311                      " must be overridden ('R'M 3.9.3(10))",
1312                      Parent (Typ), Prim);
1313                end if;
1314             end if;
1315             Next_Elmt (Prim_Elmt);
1316          end loop;
1317
1318          if Is_Controlled (Typ) then
1319             if not Finalized then
1320                Error_Msg_N
1321                  ("controlled type has no explicit Finalize method?", Typ);
1322
1323             elsif not Adjusted then
1324                Error_Msg_N
1325                  ("controlled type has no explicit Adjust method?", Typ);
1326             end if;
1327          end if;
1328
1329          Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim));
1330
1331          --  The derived type must have at least as many components as its
1332          --  parent (for root types, the Etype points back to itself
1333          --  and the test should not fail)
1334
1335          pragma Assert (
1336            DT_Entry_Count (The_Tag) >=
1337            DT_Entry_Count (First_Tag_Component (Parent_Typ)));
1338       end if;
1339    end Set_All_DT_Position;
1340
1341    -----------------------------
1342    -- Set_Default_Constructor --
1343    -----------------------------
1344
1345    procedure Set_Default_Constructor (Typ : Entity_Id) is
1346       Loc   : Source_Ptr;
1347       Init  : Entity_Id;
1348       Param : Entity_Id;
1349       E     : Entity_Id;
1350
1351    begin
1352       --  Look for the default constructor entity. For now only the
1353       --  default constructor has the flag Is_Constructor.
1354
1355       E := Next_Entity (Typ);
1356       while Present (E)
1357         and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
1358       loop
1359          Next_Entity (E);
1360       end loop;
1361
1362       --  Create the init procedure
1363
1364       if Present (E) then
1365          Loc   := Sloc (E);
1366          Init  := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
1367          Param := Make_Defining_Identifier (Loc, Name_X);
1368
1369          Discard_Node (
1370            Make_Subprogram_Declaration (Loc,
1371              Make_Procedure_Specification (Loc,
1372                Defining_Unit_Name => Init,
1373                Parameter_Specifications => New_List (
1374                  Make_Parameter_Specification (Loc,
1375                    Defining_Identifier => Param,
1376                    Parameter_Type      => New_Reference_To (Typ, Loc))))));
1377
1378          Set_Init_Proc (Typ, Init);
1379          Set_Is_Imported    (Init);
1380          Set_Interface_Name (Init, Interface_Name (E));
1381          Set_Convention     (Init, Convention_C);
1382          Set_Is_Public      (Init);
1383          Set_Has_Completion (Init);
1384
1385       --  If there are no constructors, mark the type as abstract since we
1386       --  won't be able to declare objects of that type.
1387
1388       else
1389          Set_Is_Abstract (Typ);
1390       end if;
1391    end Set_Default_Constructor;
1392
1393 end Exp_Disp;