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