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