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-2004 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          Status :=
 887            Boolean_Literals
 888              (Is_Pure (Typ)
 889                 or else Is_Shared_Passive (Typ)
 890                 or else
 891                   ((Is_Remote_Types (Typ)
 892                       or else Is_Remote_Call_Interface (Typ))
 893                    and then Original_View_In_Visible_Part (Typ))
 894                 or else not Comes_From_Source (Typ));
 895
 896          Append_To (Elab_Code,
 897            Make_DT_Access_Action (Typ,
 898              Action => Set_Remotely_Callable,
 899              Args   => New_List (
 900                New_Occurrence_Of (DT_Ptr, Loc),
 901                New_Occurrence_Of (Status, Loc))));
 902       end;
 903
 904       --  Generate: Set_External_Tag (DT_Ptr, exname'Address);
 905       --  Should be the external name not the qualified name???
 906
 907       if not Has_External_Tag_Rep_Clause (Typ) then
 908          Append_To (Elab_Code,
 909            Make_DT_Access_Action (Typ,
 910              Action => Set_External_Tag,
 911              Args   => New_List (
 912                Node1 => New_Reference_To (DT_Ptr, Loc),
 913                Node2 =>
 914                  Make_Attribute_Reference (Loc,
 915                    Prefix => New_Reference_To (Exname, Loc),
 916                    Attribute_Name => Name_Address))));
 917
 918       --  Generate code to register the Tag in the External_Tag hash
 919       --  table for the pure Ada type only.
 920
 921       --        Register_Tag (Dt_Ptr);
 922
 923       --  Skip this if routine not available, or in No_Run_Time mode
 924
 925          if RTE_Available (RE_Register_Tag)
 926            and then Is_RTE (Generalized_Tag, RE_Tag)
 927            and then not No_Run_Time_Mode
 928          then
 929             Append_To (Elab_Code,
 930               Make_Procedure_Call_Statement (Loc,
 931                 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
 932                 Parameter_Associations =>
 933                   New_List (New_Reference_To (DT_Ptr, Loc))));
 934          end if;
 935       end if;
 936
 937       --  Generate:
 938       --     if No_Reg then
 939       --        <elab_code>
 940       --        No_Reg := False;
 941       --     end if;
 942
 943       Append_To (Elab_Code,
 944         Make_Assignment_Statement (Loc,
 945           Name       => New_Reference_To (No_Reg, Loc),
 946           Expression => New_Reference_To (Standard_False, Loc)));
 947
 948       Append_To (Result,
 949         Make_Implicit_If_Statement (Typ,
 950           Condition       => New_Reference_To (No_Reg, Loc),
 951           Then_Statements => Elab_Code));
 952
 953       return Result;
 954    end Make_DT;
 955
 956    ---------------------------
 957    -- Make_DT_Access_Action --
 958    ---------------------------
 959
 960    function Make_DT_Access_Action
 961      (Typ    : Entity_Id;
 962       Action : DT_Access_Action;
 963       Args   : List_Id)
 964       return Node_Id
 965    is
 966       Action_Name : Entity_Id;
 967       Loc         : Source_Ptr;
 968
 969    begin
 970       if Is_CPP_Class (Root_Type (Typ)) then
 971          Action_Name := RTE (CPP_Actions (Action));
 972       else
 973          Action_Name := RTE (Ada_Actions (Action));
 974       end if;
 975
 976       if No (Args) then
 977
 978          --  This is a constant
 979
 980          return New_Reference_To (Action_Name, Sloc (Typ));
 981       end if;
 982
 983       pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
 984
 985       Loc := Sloc (First (Args));
 986
 987       if Action_Is_Proc (Action) then
 988          return
 989            Make_Procedure_Call_Statement (Loc,
 990              Name => New_Reference_To (Action_Name, Loc),
 991              Parameter_Associations => Args);
 992
 993       else
 994          return
 995            Make_Function_Call (Loc,
 996              Name => New_Reference_To (Action_Name, Loc),
 997              Parameter_Associations => Args);
 998       end if;
 999    end Make_DT_Access_Action;
1000
1001    -----------------------------------
1002    -- Original_View_In_Visible_Part --
1003    -----------------------------------
1004
1005    function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
1006       Scop : constant Entity_Id := Scope (Typ);
1007
1008    begin
1009       --  The scope must be a package
1010
1011       if Ekind (Scop) /= E_Package
1012         and then Ekind (Scop) /= E_Generic_Package
1013       then
1014          return False;
1015       end if;
1016
1017       --  A type with a private declaration has a private view declared in
1018       --  the visible part.
1019
1020       if Has_Private_Declaration (Typ) then
1021          return True;
1022       end if;
1023
1024       return List_Containing (Parent (Typ)) =
1025         Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
1026    end Original_View_In_Visible_Part;
1027
1028    -------------------------
1029    -- Set_All_DT_Position --
1030    -------------------------
1031
1032    procedure Set_All_DT_Position (Typ : Entity_Id) is
1033       Parent_Typ : constant Entity_Id := Etype (Typ);
1034       Root_Typ   : constant Entity_Id := Root_Type (Typ);
1035       First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
1036       The_Tag    : constant Entity_Id := Tag_Component (Typ);
1037       Adjusted   : Boolean := False;
1038       Finalized  : Boolean := False;
1039       Parent_EC  : Int;
1040       Nb_Prim    : Int;
1041       Prim       : Entity_Id;
1042       Prim_Elmt  : Elmt_Id;
1043
1044    begin
1045
1046       --  Get Entry_Count of the parent
1047
1048       if Parent_Typ /= Typ
1049         and then DT_Entry_Count (Tag_Component (Parent_Typ)) /= No_Uint
1050       then
1051          Parent_EC := UI_To_Int (DT_Entry_Count (Tag_Component (Parent_Typ)));
1052       else
1053          Parent_EC := 0;
1054       end if;
1055
1056       --  C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
1057       --  give a coherent set of information
1058
1059       if Is_CPP_Class (Root_Typ) then
1060
1061          --  Compute the number of primitive operations in the main Vtable
1062          --  Set their position:
1063          --    - where it was set if overriden or inherited
1064          --    - after the end of the parent vtable otherwise
1065
1066          Prim_Elmt := First_Prim;
1067          Nb_Prim := 0;
1068          while Present (Prim_Elmt) loop
1069             Prim := Node (Prim_Elmt);
1070
1071             if not Is_CPP_Class (Typ) then
1072                Set_DTC_Entity (Prim, The_Tag);
1073
1074             elsif Present (Alias (Prim)) then
1075                Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
1076                Set_DT_Position (Prim, DT_Position (Alias (Prim)));
1077
1078             elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
1079                   Error_Msg_NE ("is a primitive operation of&," &
1080                     " pragma Cpp_Virtual required", Prim, Typ);
1081             end if;
1082
1083             if DTC_Entity (Prim) = The_Tag then
1084
1085                --  Get the slot from the parent subprogram if any
1086
1087                declare
1088                   H : Entity_Id := Homonym (Prim);
1089
1090                begin
1091                   while Present (H) loop
1092                      if Present (DTC_Entity (H))
1093                        and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
1094                      then
1095                         Set_DT_Position (Prim, DT_Position (H));
1096                         exit;
1097                      end if;
1098
1099                      H := Homonym (H);
1100                   end loop;
1101                end;
1102
1103                --  Otherwise take the canonical slot after the end of the
1104                --  parent Vtable
1105
1106                if DT_Position (Prim) = No_Uint then
1107                   Nb_Prim := Nb_Prim + 1;
1108                   Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
1109
1110                elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
1111                   Nb_Prim := Nb_Prim + 1;
1112                end if;
1113             end if;
1114
1115             Next_Elmt (Prim_Elmt);
1116          end loop;
1117
1118          --  Check that the declared size of the Vtable is bigger or equal
1119          --  than the number of primitive operations (if bigger it means that
1120          --  some of the c++ virtual functions were not imported, that is
1121          --  allowed)
1122
1123          if DT_Entry_Count (The_Tag) = No_Uint
1124            or else not Is_CPP_Class (Typ)
1125          then
1126             Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
1127
1128          elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
1129             Error_Msg_N ("not enough room in the Vtable for all virtual"
1130               & " functions", The_Tag);
1131          end if;
1132
1133          --  Check that Positions are not duplicate nor outside the range of
1134          --  the Vtable
1135
1136          declare
1137             Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
1138             Pos  : Int;
1139             Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
1140                                                         (others => Empty);
1141
1142          begin
1143             Prim_Elmt := First_Prim;
1144             while Present (Prim_Elmt) loop
1145                Prim := Node (Prim_Elmt);
1146
1147                if DTC_Entity (Prim) = The_Tag then
1148                   Pos := UI_To_Int (DT_Position (Prim));
1149
1150                   if Pos not in Prim_Pos_Table'Range then
1151                      Error_Msg_N
1152                        ("position not in range of virtual table", Prim);
1153
1154                   elsif Present (Prim_Pos_Table (Pos)) then
1155                      Error_Msg_NE ("cannot be at the same position in the"
1156                        & " vtable than&", Prim, Prim_Pos_Table (Pos));
1157
1158                   else
1159                      Prim_Pos_Table (Pos) := Prim;
1160                   end if;
1161                end if;
1162
1163                Next_Elmt (Prim_Elmt);
1164             end loop;
1165          end;
1166
1167       --  For regular Ada tagged types, just set the DT_Position for
1168       --  each primitive operation. Perform some sanity checks to avoid
1169       --  to build completely inconsistant dispatch tables.
1170
1171       --  Note that the _Size primitive is always set at position 1 in order
1172       --  to comply with the needs of Ada.Tags.Parent_Size (see documentation
1173       --  in a-tags.ad?)
1174
1175       else
1176          Nb_Prim := 1;
1177          Prim_Elmt := First_Prim;
1178          while Present (Prim_Elmt) loop
1179             Nb_Prim := Nb_Prim + 1;
1180             Prim := Node (Prim_Elmt);
1181             Set_DTC_Entity (Prim, The_Tag);
1182
1183             if Chars (Prim) = Name_uSize then
1184                Set_DT_Position (Prim, Uint_1);
1185                Nb_Prim := Nb_Prim - 1;
1186             else
1187                Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
1188             end if;
1189
1190             if Chars (Prim) = Name_Finalize
1191               and then
1192                 (Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
1193                    or else not Is_Predefined_File_Name
1194                                   (Unit_File_Name (Get_Source_Unit (Prim))))
1195             then
1196                Finalized := True;
1197             end if;
1198
1199             if Chars (Prim) = Name_Adjust then
1200                Adjusted := True;
1201             end if;
1202
1203             --  An abstract operation cannot be declared in the private part
1204             --  for a visible abstract type, because it could never be over-
1205             --  ridden. For explicit declarations this is checked at the point
1206             --  of declaration, but for inherited operations it must be done
1207             --  when building the dispatch table. Input is excluded because
1208
1209             if Is_Abstract (Typ)
1210               and then Is_Abstract (Prim)
1211               and then Present (Alias (Prim))
1212               and then Is_Derived_Type (Typ)
1213               and then In_Private_Part (Current_Scope)
1214               and then List_Containing (Parent (Prim))
1215                =  Private_Declarations
1216                    (Specification (Unit_Declaration_Node (Current_Scope)))
1217               and then Original_View_In_Visible_Part (Typ)
1218             then
1219                --  We exclude Input and Output stream operations because
1220                --  Limited_Controlled inherits useless Input and Output
1221                --  stream operations from Root_Controlled, which can
1222                --  never be overridden.
1223
1224                if not Is_TSS (Prim, TSS_Stream_Input)
1225                     and then
1226                   not Is_TSS (Prim, TSS_Stream_Output)
1227                then
1228                   Error_Msg_NE
1229                     ("abstract inherited private operation&" &
1230                      " must be overridden ('R'M 3.9.3(10))",
1231                      Parent (Typ), Prim);
1232                end if;
1233             end if;
1234             Next_Elmt (Prim_Elmt);
1235          end loop;
1236
1237          if Is_Controlled (Typ) then
1238             if not Finalized then
1239                Error_Msg_N
1240                  ("controlled type has no explicit Finalize method?", Typ);
1241
1242             elsif not Adjusted then
1243                Error_Msg_N
1244                  ("controlled type has no explicit Adjust method?", Typ);
1245             end if;
1246          end if;
1247
1248          Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim));
1249
1250          --  The derived type must have at least as many components as its
1251          --  parent (for root types, the Etype points back to itself
1252          --  and the test should not fail)
1253
1254          pragma Assert (
1255            DT_Entry_Count (The_Tag) >=
1256            DT_Entry_Count (Tag_Component (Parent_Typ)));
1257       end if;
1258    end Set_All_DT_Position;
1259
1260    -----------------------------
1261    -- Set_Default_Constructor --
1262    -----------------------------
1263
1264    procedure Set_Default_Constructor (Typ : Entity_Id) is
1265       Loc   : Source_Ptr;
1266       Init  : Entity_Id;
1267       Param : Entity_Id;
1268       E     : Entity_Id;
1269
1270    begin
1271       --  Look for the default constructor entity. For now only the
1272       --  default constructor has the flag Is_Constructor.
1273
1274       E := Next_Entity (Typ);
1275       while Present (E)
1276         and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
1277       loop
1278          Next_Entity (E);
1279       end loop;
1280
1281       --  Create the init procedure
1282
1283       if Present (E) then
1284          Loc   := Sloc (E);
1285          Init  := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
1286          Param := Make_Defining_Identifier (Loc, Name_X);
1287
1288          Discard_Node (
1289            Make_Subprogram_Declaration (Loc,
1290              Make_Procedure_Specification (Loc,
1291                Defining_Unit_Name => Init,
1292                Parameter_Specifications => New_List (
1293                  Make_Parameter_Specification (Loc,
1294                    Defining_Identifier => Param,
1295                    Parameter_Type      => New_Reference_To (Typ, Loc))))));
1296
1297          Set_Init_Proc (Typ, Init);
1298          Set_Is_Imported    (Init);
1299          Set_Interface_Name (Init, Interface_Name (E));
1300          Set_Convention     (Init, Convention_C);
1301          Set_Is_Public      (Init);
1302          Set_Has_Completion (Init);
1303
1304       --  If there are no constructors, mark the type as abstract since we
1305       --  won't be able to declare objects of that type.
1306
1307       else
1308          Set_Is_Abstract (Typ);
1309       end if;
1310    end Set_Default_Constructor;
1311
1312 end Exp_Disp;