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