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