gcc/ada/exp_atag.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ A T A G                              --
   6 --                                                                          --
   7 --                                 S p e c                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2006-2011, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Einfo;    use Einfo;
  28 with Elists;   use Elists;
  29 with Exp_Disp; use Exp_Disp;
  30 with Exp_Util; use Exp_Util;
  31 with Namet;    use Namet;
  32 with Nlists;   use Nlists;
  33 with Nmake;    use Nmake;
  34 with Opt;      use Opt;
  35 with Rtsfind;  use Rtsfind;
  36 with Sinfo;    use Sinfo;
  37 with Sem_Aux;  use Sem_Aux;
  38 with Sem_Disp; use Sem_Disp;
  39 with Sem_Util; use Sem_Util;
  40 with Stand;    use Stand;
  41 with Snames;   use Snames;
  42 with Tbuild;   use Tbuild;
  43
  44 package body Exp_Atag is
  45
  46    -----------------------
  47    -- Local Subprograms --
  48    -----------------------
  49
  50    function Build_DT
  51      (Loc      : Source_Ptr;
  52       Tag_Node : Node_Id) return Node_Id;
  53    --  Build code that displaces the Tag to reference the base of the wrapper
  54    --  record
  55    --
  56    --  Generates:
  57    --    To_Dispatch_Table_Ptr
  58    --      (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
  59
  60    function Build_TSD
  61      (Loc           : Source_Ptr;
  62       Tag_Node_Addr : Node_Id) return Node_Id;
  63    --  Build code that retrieves the address of the record containing the Type
  64    --  Specific Data generated by GNAT.
  65    --
  66    --  Generate: To_Type_Specific_Data_Ptr
  67    --              (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);
  68
  69    ------------------------------------------------
  70    -- Build_Common_Dispatching_Select_Statements --
  71    ------------------------------------------------
  72
  73    procedure Build_Common_Dispatching_Select_Statements
  74      (Typ    : Entity_Id;
  75       Stmts  : List_Id)
  76    is
  77       Loc      : constant Source_Ptr := Sloc (Typ);
  78       Tag_Node : Node_Id;
  79
  80    begin
  81       --  Generate:
  82       --    C := get_prim_op_kind (tag! (<type>VP), S);
  83
  84       --  where C is the out parameter capturing the call kind and S is the
  85       --  dispatch table slot number.
  86
  87       if Tagged_Type_Expansion then
  88          Tag_Node :=
  89            Unchecked_Convert_To (RTE (RE_Tag),
  90              New_Reference_To
  91               (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));
  92
  93       else
  94          Tag_Node :=
  95            Make_Attribute_Reference (Loc,
  96              Prefix => New_Reference_To (Typ, Loc),
  97              Attribute_Name => Name_Tag);
  98       end if;
  99
 100       Append_To (Stmts,
 101         Make_Assignment_Statement (Loc,
 102           Name => Make_Identifier (Loc, Name_uC),
 103           Expression =>
 104             Make_Function_Call (Loc,
 105               Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
 106               Parameter_Associations => New_List (
 107                 Tag_Node,
 108                 Make_Identifier (Loc, Name_uS)))));
 109
 110       --  Generate:
 111
 112       --    if C = POK_Procedure
 113       --      or else C = POK_Protected_Procedure
 114       --      or else C = POK_Task_Procedure;
 115       --    then
 116       --       F := True;
 117       --       return;
 118
 119       --  where F is the out parameter capturing the status of a potential
 120       --  entry call.
 121
 122       Append_To (Stmts,
 123         Make_If_Statement (Loc,
 124
 125           Condition =>
 126             Make_Or_Else (Loc,
 127               Left_Opnd =>
 128                 Make_Op_Eq (Loc,
 129                   Left_Opnd  => Make_Identifier (Loc, Name_uC),
 130                   Right_Opnd =>
 131                     New_Reference_To (RTE (RE_POK_Procedure), Loc)),
 132               Right_Opnd =>
 133                 Make_Or_Else (Loc,
 134                   Left_Opnd =>
 135                     Make_Op_Eq (Loc,
 136                       Left_Opnd => Make_Identifier (Loc, Name_uC),
 137                       Right_Opnd =>
 138                         New_Reference_To
 139                           (RTE (RE_POK_Protected_Procedure), Loc)),
 140                   Right_Opnd =>
 141                     Make_Op_Eq (Loc,
 142                       Left_Opnd  => Make_Identifier (Loc, Name_uC),
 143                       Right_Opnd =>
 144                         New_Reference_To
 145                           (RTE (RE_POK_Task_Procedure), Loc)))),
 146
 147           Then_Statements =>
 148             New_List (
 149               Make_Assignment_Statement (Loc,
 150                 Name       => Make_Identifier (Loc, Name_uF),
 151                 Expression => New_Reference_To (Standard_True, Loc)),
 152               Make_Simple_Return_Statement (Loc))));
 153    end Build_Common_Dispatching_Select_Statements;
 154
 155    -------------------------
 156    -- Build_CW_Membership --
 157    -------------------------
 158
 159    procedure Build_CW_Membership
 160      (Loc          : Source_Ptr;
 161       Obj_Tag_Node : in out Node_Id;
 162       Typ_Tag_Node : Node_Id;
 163       Related_Nod  : Node_Id;
 164       New_Node     : out Node_Id)
 165    is
 166       Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node);
 167       Obj_TSD  : constant Entity_Id := Make_Temporary (Loc, 'D');
 168       Typ_TSD  : constant Entity_Id := Make_Temporary (Loc, 'D');
 169       Index    : constant Entity_Id := Make_Temporary (Loc, 'D');
 170
 171    begin
 172       --  Generate:
 173
 174       --    Tag_Addr : constant Tag := Address!(Obj_Tag);
 175       --    Obj_TSD  : constant Type_Specific_Data_Ptr
 176       --                          := Build_TSD (Tag_Addr);
 177       --    Typ_TSD  : constant Type_Specific_Data_Ptr
 178       --                          := Build_TSD (Address!(Typ_Tag));
 179       --    Index    : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth
 180       --    Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag
 181
 182       Insert_Action (Related_Nod,
 183         Make_Object_Declaration (Loc,
 184           Defining_Identifier => Tag_Addr,
 185           Constant_Present    => True,
 186           Object_Definition   => New_Reference_To (RTE (RE_Address), Loc),
 187           Expression          => Unchecked_Convert_To
 188                                    (RTE (RE_Address), Obj_Tag_Node)));
 189
 190       --  Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must
 191       --  update it.
 192
 193       Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));
 194
 195       Insert_Action (Related_Nod,
 196         Make_Object_Declaration (Loc,
 197           Defining_Identifier => Obj_TSD,
 198           Constant_Present    => True,
 199           Object_Definition   => New_Reference_To
 200                                    (RTE (RE_Type_Specific_Data_Ptr), Loc),
 201           Expression => Build_TSD (Loc, New_Reference_To (Tag_Addr, Loc))));
 202
 203       Insert_Action (Related_Nod,
 204         Make_Object_Declaration (Loc,
 205           Defining_Identifier => Typ_TSD,
 206           Constant_Present    => True,
 207           Object_Definition   => New_Reference_To
 208                                    (RTE (RE_Type_Specific_Data_Ptr), Loc),
 209           Expression => Build_TSD (Loc,
 210                           Unchecked_Convert_To (RTE (RE_Address),
 211                             Typ_Tag_Node))));
 212
 213       Insert_Action (Related_Nod,
 214         Make_Object_Declaration (Loc,
 215           Defining_Identifier => Index,
 216           Constant_Present    => True,
 217           Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc),
 218           Expression =>
 219             Make_Op_Subtract (Loc,
 220               Left_Opnd =>
 221                 Make_Selected_Component (Loc,
 222                   Prefix        => New_Reference_To (Obj_TSD, Loc),
 223                   Selector_Name =>
 224                      New_Reference_To
 225                        (RTE_Record_Component (RE_Idepth), Loc)),
 226
 227                Right_Opnd =>
 228                  Make_Selected_Component (Loc,
 229                    Prefix        => New_Reference_To (Typ_TSD, Loc),
 230                    Selector_Name =>
 231                      New_Reference_To
 232                        (RTE_Record_Component (RE_Idepth), Loc)))));
 233
 234       New_Node :=
 235         Make_And_Then (Loc,
 236           Left_Opnd =>
 237             Make_Op_Ge (Loc,
 238               Left_Opnd  => New_Occurrence_Of (Index, Loc),
 239               Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
 240
 241           Right_Opnd =>
 242             Make_Op_Eq (Loc,
 243               Left_Opnd =>
 244                 Make_Indexed_Component (Loc,
 245                   Prefix =>
 246                     Make_Selected_Component (Loc,
 247                       Prefix        => New_Reference_To (Obj_TSD, Loc),
 248                       Selector_Name =>
 249                         New_Reference_To
 250                           (RTE_Record_Component (RE_Tags_Table), Loc)),
 251                   Expressions =>
 252                     New_List (New_Occurrence_Of (Index, Loc))),
 253
 254               Right_Opnd => Typ_Tag_Node));
 255    end Build_CW_Membership;
 256
 257    --------------
 258    -- Build_DT --
 259    --------------
 260
 261    function Build_DT
 262      (Loc      : Source_Ptr;
 263       Tag_Node : Node_Id) return Node_Id
 264    is
 265    begin
 266       return
 267         Make_Function_Call (Loc,
 268           Name => New_Reference_To (RTE (RE_DT), Loc),
 269           Parameter_Associations => New_List (
 270             Unchecked_Convert_To (RTE (RE_Tag), Tag_Node)));
 271    end Build_DT;
 272
 273    ----------------------------
 274    -- Build_Get_Access_Level --
 275    ----------------------------
 276
 277    function Build_Get_Access_Level
 278      (Loc      : Source_Ptr;
 279       Tag_Node : Node_Id) return Node_Id
 280    is
 281    begin
 282       return
 283         Make_Selected_Component (Loc,
 284           Prefix =>
 285             Build_TSD (Loc,
 286               Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
 287           Selector_Name =>
 288             New_Reference_To
 289               (RTE_Record_Component (RE_Access_Level), Loc));
 290    end Build_Get_Access_Level;
 291
 292    ------------------------------------------
 293    -- Build_Get_Predefined_Prim_Op_Address --
 294    ------------------------------------------
 295
 296    procedure Build_Get_Predefined_Prim_Op_Address
 297      (Loc      : Source_Ptr;
 298       Position : Uint;
 299       Tag_Node : in out Node_Id;
 300       New_Node : out Node_Id)
 301    is
 302       Ctrl_Tag : Node_Id;
 303
 304    begin
 305       Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node);
 306
 307       --  Unchecked_Convert_To relocates the controlling tag node and therefore
 308       --  we must update it.
 309
 310       Tag_Node := Expression (Ctrl_Tag);
 311
 312       --  Build code that retrieves the address of the dispatch table
 313       --  containing the predefined Ada primitives:
 314       --
 315       --  Generate:
 316       --    To_Predef_Prims_Table_Ptr
 317       --     (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
 318
 319       New_Node :=
 320         Make_Indexed_Component (Loc,
 321           Prefix =>
 322             Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 323               Make_Explicit_Dereference (Loc,
 324                 Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 325                   Make_Function_Call (Loc,
 326                     Name =>
 327                       Make_Expanded_Name (Loc,
 328                         Chars => Name_Op_Subtract,
 329                         Prefix =>
 330                           New_Reference_To
 331                             (RTU_Entity (System_Storage_Elements), Loc),
 332                         Selector_Name =>
 333                           Make_Identifier (Loc, Name_Op_Subtract)),
 334                     Parameter_Associations => New_List (
 335                       Ctrl_Tag,
 336                       New_Reference_To
 337                         (RTE (RE_DT_Predef_Prims_Offset), Loc)))))),
 338           Expressions =>
 339             New_List (Make_Integer_Literal (Loc, Position)));
 340    end Build_Get_Predefined_Prim_Op_Address;
 341
 342    -----------------------------
 343    -- Build_Inherit_CPP_Prims --
 344    -----------------------------
 345
 346    function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is
 347       Loc          : constant Source_Ptr := Sloc (Typ);
 348       CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
 349       CPP_Table    : array (1 .. CPP_Nb_Prims) of Boolean := (others => False);
 350       CPP_Typ      : constant Entity_Id := Enclosing_CPP_Parent (Typ);
 351       Result       : constant List_Id   := New_List;
 352       Parent_Typ   : constant Entity_Id := Etype (Typ);
 353       E            : Entity_Id;
 354       Elmt         : Elmt_Id;
 355       Parent_Tag   : Entity_Id;
 356       Prim         : Entity_Id;
 357       Prim_Pos     : Nat;
 358       Typ_Tag      : Entity_Id;
 359
 360    begin
 361       pragma Assert (not Is_CPP_Class (Typ));
 362
 363       --  No code needed if this type has no primitives inherited from C++
 364
 365       if CPP_Nb_Prims = 0 then
 366          return Result;
 367       end if;
 368
 369       --  Stage 1: Inherit and override C++ slots of the primary dispatch table
 370
 371       --  Generate:
 372       --     Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access;
 373
 374       Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ)));
 375       Typ_Tag    := Node (First_Elmt (Access_Disp_Table (Typ)));
 376
 377       Elmt := First_Elmt (Primitive_Operations (Typ));
 378       while Present (Elmt) loop
 379          Prim     := Node (Elmt);
 380          E        := Ultimate_Alias (Prim);
 381          Prim_Pos := UI_To_Int (DT_Position (E));
 382
 383          --  Skip predefined, abstract, and eliminated primitives. Skip also
 384          --  primitives not located in the C++ part of the dispatch table.
 385
 386          if not Is_Predefined_Dispatching_Operation (Prim)
 387            and then not Is_Predefined_Dispatching_Operation (E)
 388            and then not Present (Interface_Alias (Prim))
 389            and then not Is_Abstract_Subprogram (E)
 390            and then not Is_Eliminated (E)
 391            and then Prim_Pos <= CPP_Nb_Prims
 392            and then Find_Dispatching_Type (E) = Typ
 393          then
 394             --  Remember that this slot is used
 395
 396             pragma Assert (CPP_Table (Prim_Pos) = False);
 397             CPP_Table (Prim_Pos) := True;
 398
 399             Append_To (Result,
 400               Make_Assignment_Statement (Loc,
 401                 Name =>
 402                   Make_Indexed_Component (Loc,
 403                     Prefix =>
 404                       Make_Explicit_Dereference (Loc,
 405                         Unchecked_Convert_To
 406                           (Node (Last_Elmt (Access_Disp_Table (Typ))),
 407                            New_Reference_To (Typ_Tag, Loc))),
 408                     Expressions =>
 409                        New_List (Make_Integer_Literal (Loc, Prim_Pos))),
 410
 411                Expression =>
 412                  Unchecked_Convert_To (RTE (RE_Prim_Ptr),
 413                    Make_Attribute_Reference (Loc,
 414                      Prefix => New_Reference_To (E, Loc),
 415                      Attribute_Name => Name_Unrestricted_Access))));
 416          end if;
 417
 418          Next_Elmt (Elmt);
 419       end loop;
 420
 421       --  If all primitives have been overridden then there is no need to copy
 422       --  from Typ's parent its dispatch table. Otherwise, if some primitive is
 423       --  inherited from the parent we copy only the C++ part of the dispatch
 424       --  table from the parent before the assignments that initialize the
 425       --  overridden primitives.
 426
 427       --  Generate:
 428
 429       --     type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr;
 430       --     type CPP_TypH is access CPP_TypG;
 431       --     CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all;
 432
 433       --   Note: There is no need to duplicate the declarations of CPP_TypG and
 434       --         CPP_TypH because, for expansion of dispatching calls, these
 435       --         entities are stored in the last elements of Access_Disp_Table.
 436
 437       for J in CPP_Table'Range loop
 438          if not CPP_Table (J) then
 439             Prepend_To (Result,
 440               Make_Assignment_Statement (Loc,
 441                 Name =>
 442                   Make_Explicit_Dereference (Loc,
 443                     Unchecked_Convert_To
 444                       (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
 445                        New_Reference_To (Typ_Tag, Loc))),
 446                 Expression =>
 447                   Make_Explicit_Dereference (Loc,
 448                     Unchecked_Convert_To
 449                       (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
 450                        New_Reference_To (Parent_Tag, Loc)))));
 451             exit;
 452          end if;
 453       end loop;
 454
 455       --  Stage 2: Inherit and override C++ slots of secondary dispatch tables
 456
 457       declare
 458          Iface                   : Entity_Id;
 459          Iface_Nb_Prims          : Nat;
 460          Parent_Ifaces_List      : Elist_Id;
 461          Parent_Ifaces_Comp_List : Elist_Id;
 462          Parent_Ifaces_Tag_List  : Elist_Id;
 463          Parent_Iface_Tag_Elmt   : Elmt_Id;
 464          Typ_Ifaces_List         : Elist_Id;
 465          Typ_Ifaces_Comp_List    : Elist_Id;
 466          Typ_Ifaces_Tag_List     : Elist_Id;
 467          Typ_Iface_Tag_Elmt      : Elmt_Id;
 468
 469       begin
 470          Collect_Interfaces_Info
 471            (T               => Parent_Typ,
 472             Ifaces_List     => Parent_Ifaces_List,
 473             Components_List => Parent_Ifaces_Comp_List,
 474             Tags_List       => Parent_Ifaces_Tag_List);
 475
 476          Collect_Interfaces_Info
 477            (T               => Typ,
 478             Ifaces_List     => Typ_Ifaces_List,
 479             Components_List => Typ_Ifaces_Comp_List,
 480             Tags_List       => Typ_Ifaces_Tag_List);
 481
 482          Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List);
 483          Typ_Iface_Tag_Elmt    := First_Elmt (Typ_Ifaces_Tag_List);
 484          while Present (Parent_Iface_Tag_Elmt) loop
 485             Parent_Tag := Node (Parent_Iface_Tag_Elmt);
 486             Typ_Tag    := Node (Typ_Iface_Tag_Elmt);
 487
 488             pragma Assert
 489               (Related_Type (Parent_Tag) = Related_Type (Typ_Tag));
 490             Iface := Related_Type (Parent_Tag);
 491
 492             Iface_Nb_Prims :=
 493               UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)));
 494
 495             if Iface_Nb_Prims > 0 then
 496
 497                --  Update slots of overridden primitives
 498
 499                declare
 500                   Last_Nod : constant Node_Id := Last (Result);
 501                   Nb_Prims : constant Nat := UI_To_Int
 502                                               (DT_Entry_Count
 503                                                (First_Tag_Component (Iface)));
 504                   Elmt     : Elmt_Id;
 505                   Prim     : Entity_Id;
 506                   E        : Entity_Id;
 507                   Prim_Pos : Nat;
 508
 509                   Prims_Table : array (1 .. Nb_Prims) of Boolean;
 510
 511                begin
 512                   Prims_Table := (others => False);
 513
 514                   Elmt := First_Elmt (Primitive_Operations (Typ));
 515                   while Present (Elmt) loop
 516                      Prim := Node (Elmt);
 517                      E    := Ultimate_Alias (Prim);
 518
 519                      if not Is_Predefined_Dispatching_Operation (Prim)
 520                        and then Present (Interface_Alias (Prim))
 521                        and then Find_Dispatching_Type (Interface_Alias (Prim))
 522                                   = Iface
 523                        and then not Is_Abstract_Subprogram (E)
 524                        and then not Is_Eliminated (E)
 525                        and then Find_Dispatching_Type (E) = Typ
 526                      then
 527                         Prim_Pos := UI_To_Int (DT_Position (Prim));
 528
 529                         --  Remember that this slot is already initialized
 530
 531                         pragma Assert (Prims_Table (Prim_Pos) = False);
 532                         Prims_Table (Prim_Pos) := True;
 533
 534                         Append_To (Result,
 535                           Make_Assignment_Statement (Loc,
 536                             Name =>
 537                               Make_Indexed_Component (Loc,
 538                                 Prefix =>
 539                                   Make_Explicit_Dereference (Loc,
 540                                     Unchecked_Convert_To
 541                                       (Node
 542                                         (Last_Elmt
 543                                           (Access_Disp_Table (Iface))),
 544                                        New_Reference_To (Typ_Tag, Loc))),
 545                                 Expressions =>
 546                                    New_List
 547                                     (Make_Integer_Literal (Loc, Prim_Pos))),
 548
 549                             Expression =>
 550                               Unchecked_Convert_To (RTE (RE_Prim_Ptr),
 551                                 Make_Attribute_Reference (Loc,
 552                                   Prefix => New_Reference_To (E, Loc),
 553                                   Attribute_Name =>
 554                                     Name_Unrestricted_Access))));
 555                      end if;
 556
 557                      Next_Elmt (Elmt);
 558                   end loop;
 559
 560                   --  Check if all primitives from the parent have been
 561                   --  overridden (to avoid copying the whole secondary
 562                   --  table from the parent).
 563
 564                   --   IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all;
 565
 566                   for J in Prims_Table'Range loop
 567                      if not Prims_Table (J) then
 568                         Insert_After (Last_Nod,
 569                           Make_Assignment_Statement (Loc,
 570                             Name =>
 571                               Make_Explicit_Dereference (Loc,
 572                                 Unchecked_Convert_To
 573                                  (Node (Last_Elmt (Access_Disp_Table (Iface))),
 574                                   New_Reference_To (Typ_Tag, Loc))),
 575                             Expression =>
 576                               Make_Explicit_Dereference (Loc,
 577                                 Unchecked_Convert_To
 578                                  (Node (Last_Elmt (Access_Disp_Table (Iface))),
 579                                   New_Reference_To (Parent_Tag, Loc)))));
 580                         exit;
 581                      end if;
 582                   end loop;
 583                end;
 584             end if;
 585
 586             Next_Elmt (Typ_Iface_Tag_Elmt);
 587             Next_Elmt (Parent_Iface_Tag_Elmt);
 588          end loop;
 589       end;
 590
 591       return Result;
 592    end Build_Inherit_CPP_Prims;
 593
 594    -------------------------
 595    -- Build_Inherit_Prims --
 596    -------------------------
 597
 598    function Build_Inherit_Prims
 599      (Loc          : Source_Ptr;
 600       Typ          : Entity_Id;
 601       Old_Tag_Node : Node_Id;
 602       New_Tag_Node : Node_Id;
 603       Num_Prims    : Nat) return Node_Id
 604    is
 605    begin
 606       if RTE_Available (RE_DT) then
 607          return
 608            Make_Assignment_Statement (Loc,
 609              Name =>
 610                Make_Slice (Loc,
 611                  Prefix =>
 612                    Make_Selected_Component (Loc,
 613                      Prefix =>
 614                        Build_DT (Loc, New_Tag_Node),
 615                      Selector_Name =>
 616                        New_Reference_To
 617                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 618                  Discrete_Range =>
 619                    Make_Range (Loc,
 620                    Low_Bound  => Make_Integer_Literal (Loc, 1),
 621                    High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
 622
 623              Expression =>
 624                Make_Slice (Loc,
 625                  Prefix =>
 626                    Make_Selected_Component (Loc,
 627                      Prefix =>
 628                        Build_DT (Loc, Old_Tag_Node),
 629                      Selector_Name =>
 630                        New_Reference_To
 631                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 632                  Discrete_Range =>
 633                    Make_Range (Loc,
 634                      Low_Bound  => Make_Integer_Literal (Loc, 1),
 635                      High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
 636       else
 637          return
 638            Make_Assignment_Statement (Loc,
 639              Name =>
 640                Make_Slice (Loc,
 641                  Prefix =>
 642                    Unchecked_Convert_To
 643                      (Node (Last_Elmt (Access_Disp_Table (Typ))),
 644                       New_Tag_Node),
 645                  Discrete_Range =>
 646                    Make_Range (Loc,
 647                    Low_Bound  => Make_Integer_Literal (Loc, 1),
 648                    High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
 649
 650              Expression =>
 651                Make_Slice (Loc,
 652                  Prefix =>
 653                    Unchecked_Convert_To
 654                      (Node (Last_Elmt (Access_Disp_Table (Typ))),
 655                       Old_Tag_Node),
 656                  Discrete_Range =>
 657                    Make_Range (Loc,
 658                      Low_Bound  => Make_Integer_Literal (Loc, 1),
 659                      High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
 660       end if;
 661    end Build_Inherit_Prims;
 662
 663    -------------------------------
 664    -- Build_Get_Prim_Op_Address --
 665    -------------------------------
 666
 667    procedure Build_Get_Prim_Op_Address
 668      (Loc      : Source_Ptr;
 669       Typ      : Entity_Id;
 670       Position : Uint;
 671       Tag_Node : in out Node_Id;
 672       New_Node : out Node_Id)
 673    is
 674       New_Prefix : Node_Id;
 675
 676    begin
 677       pragma Assert
 678         (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
 679
 680       --  At the end of the Access_Disp_Table list we have the type
 681       --  declaration required to convert the tag into a pointer to
 682       --  the prims_ptr table (see Freeze_Record_Type).
 683
 684       New_Prefix :=
 685         Unchecked_Convert_To
 686           (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node);
 687
 688       --  Unchecked_Convert_To relocates the controlling tag node and therefore
 689       --  we must update it.
 690
 691       Tag_Node := Expression (New_Prefix);
 692
 693       New_Node :=
 694         Make_Indexed_Component (Loc,
 695           Prefix      => New_Prefix,
 696           Expressions => New_List (Make_Integer_Literal (Loc, Position)));
 697    end Build_Get_Prim_Op_Address;
 698
 699    -----------------------------
 700    -- Build_Get_Transportable --
 701    -----------------------------
 702
 703    function Build_Get_Transportable
 704      (Loc      : Source_Ptr;
 705       Tag_Node : Node_Id) return Node_Id
 706    is
 707    begin
 708       return
 709         Make_Selected_Component (Loc,
 710           Prefix =>
 711             Build_TSD (Loc,
 712               Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
 713           Selector_Name =>
 714             New_Reference_To
 715               (RTE_Record_Component (RE_Transportable), Loc));
 716    end Build_Get_Transportable;
 717
 718    ------------------------------------
 719    -- Build_Inherit_Predefined_Prims --
 720    ------------------------------------
 721
 722    function Build_Inherit_Predefined_Prims
 723      (Loc          : Source_Ptr;
 724       Old_Tag_Node : Node_Id;
 725       New_Tag_Node : Node_Id) return Node_Id
 726    is
 727    begin
 728       return
 729         Make_Assignment_Statement (Loc,
 730           Name =>
 731             Make_Slice (Loc,
 732               Prefix =>
 733                 Make_Explicit_Dereference (Loc,
 734                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 735                     Make_Explicit_Dereference (Loc,
 736                       Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 737                         New_Tag_Node)))),
 738               Discrete_Range => Make_Range (Loc,
 739                 Make_Integer_Literal (Loc, Uint_1),
 740                 New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
 741
 742           Expression =>
 743             Make_Slice (Loc,
 744               Prefix =>
 745                 Make_Explicit_Dereference (Loc,
 746                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 747                     Make_Explicit_Dereference (Loc,
 748                       Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 749                         Old_Tag_Node)))),
 750               Discrete_Range =>
 751                 Make_Range (Loc,
 752                   Make_Integer_Literal (Loc, 1),
 753                   New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
 754    end Build_Inherit_Predefined_Prims;
 755
 756    -------------------------
 757    -- Build_Offset_To_Top --
 758    -------------------------
 759
 760    function Build_Offset_To_Top
 761      (Loc       : Source_Ptr;
 762       This_Node : Node_Id) return Node_Id
 763    is
 764       Tag_Node : Node_Id;
 765
 766    begin
 767       Tag_Node :=
 768         Make_Explicit_Dereference (Loc,
 769           Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
 770
 771       return
 772         Make_Explicit_Dereference (Loc,
 773           Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
 774             Make_Function_Call (Loc,
 775               Name =>
 776                 Make_Expanded_Name (Loc,
 777                   Chars         => Name_Op_Subtract,
 778                   Prefix        =>
 779                     New_Reference_To
 780                       (RTU_Entity (System_Storage_Elements), Loc),
 781                   Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)),
 782               Parameter_Associations => New_List (
 783                 Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 784                 New_Reference_To
 785                   (RTE (RE_DT_Offset_To_Top_Offset), Loc)))));
 786    end Build_Offset_To_Top;
 787
 788    ------------------------------------------
 789    -- Build_Set_Predefined_Prim_Op_Address --
 790    ------------------------------------------
 791
 792    function Build_Set_Predefined_Prim_Op_Address
 793      (Loc          : Source_Ptr;
 794       Tag_Node     : Node_Id;
 795       Position     : Uint;
 796       Address_Node : Node_Id) return Node_Id
 797    is
 798    begin
 799       return
 800          Make_Assignment_Statement (Loc,
 801            Name =>
 802              Make_Indexed_Component (Loc,
 803                Prefix =>
 804                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 805                    Make_Explicit_Dereference (Loc,
 806                      Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
 807                Expressions =>
 808                  New_List (Make_Integer_Literal (Loc, Position))),
 809
 810            Expression => Address_Node);
 811    end Build_Set_Predefined_Prim_Op_Address;
 812
 813    -------------------------------
 814    -- Build_Set_Prim_Op_Address --
 815    -------------------------------
 816
 817    function Build_Set_Prim_Op_Address
 818      (Loc          : Source_Ptr;
 819       Typ          : Entity_Id;
 820       Tag_Node     : Node_Id;
 821       Position     : Uint;
 822       Address_Node : Node_Id) return Node_Id
 823    is
 824       Ctrl_Tag : Node_Id := Tag_Node;
 825       New_Node : Node_Id;
 826
 827    begin
 828       Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node);
 829
 830       return
 831         Make_Assignment_Statement (Loc,
 832           Name       => New_Node,
 833           Expression => Address_Node);
 834    end Build_Set_Prim_Op_Address;
 835
 836    -----------------------------
 837    -- Build_Set_Size_Function --
 838    -----------------------------
 839
 840    function Build_Set_Size_Function
 841      (Loc       : Source_Ptr;
 842       Tag_Node  : Node_Id;
 843       Size_Func : Entity_Id) return Node_Id is
 844    begin
 845       pragma Assert (Chars (Size_Func) = Name_uSize
 846         and then RTE_Record_Component_Available (RE_Size_Func));
 847       return
 848         Make_Assignment_Statement (Loc,
 849           Name =>
 850             Make_Selected_Component (Loc,
 851               Prefix =>
 852                 Build_TSD (Loc,
 853                   Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
 854               Selector_Name =>
 855                 New_Reference_To
 856                   (RTE_Record_Component (RE_Size_Func), Loc)),
 857           Expression =>
 858             Unchecked_Convert_To (RTE (RE_Size_Ptr),
 859               Make_Attribute_Reference (Loc,
 860                 Prefix => New_Reference_To (Size_Func, Loc),
 861                 Attribute_Name => Name_Unrestricted_Access)));
 862    end Build_Set_Size_Function;
 863
 864    ------------------------------------
 865    -- Build_Set_Static_Offset_To_Top --
 866    ------------------------------------
 867
 868    function Build_Set_Static_Offset_To_Top
 869      (Loc          : Source_Ptr;
 870       Iface_Tag    : Node_Id;
 871       Offset_Value : Node_Id) return Node_Id is
 872    begin
 873       return
 874         Make_Assignment_Statement (Loc,
 875           Make_Explicit_Dereference (Loc,
 876             Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
 877               Make_Function_Call (Loc,
 878                 Name =>
 879                   Make_Expanded_Name (Loc,
 880                     Chars         => Name_Op_Subtract,
 881                     Prefix        =>
 882                       New_Reference_To
 883                         (RTU_Entity (System_Storage_Elements), Loc),
 884                     Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)),
 885                 Parameter_Associations => New_List (
 886                   Unchecked_Convert_To (RTE (RE_Address), Iface_Tag),
 887                   New_Reference_To
 888                     (RTE (RE_DT_Offset_To_Top_Offset), Loc))))),
 889           Offset_Value);
 890    end Build_Set_Static_Offset_To_Top;
 891
 892    ---------------
 893    -- Build_TSD --
 894    ---------------
 895
 896    function Build_TSD
 897      (Loc           : Source_Ptr;
 898       Tag_Node_Addr : Node_Id) return Node_Id is
 899    begin
 900       return
 901         Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
 902           Make_Explicit_Dereference (Loc,
 903             Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 904               Make_Function_Call (Loc,
 905                 Name =>
 906                   Make_Expanded_Name (Loc,
 907                     Chars => Name_Op_Subtract,
 908                     Prefix =>
 909                       New_Reference_To
 910                         (RTU_Entity (System_Storage_Elements), Loc),
 911                     Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)),
 912
 913                 Parameter_Associations => New_List (
 914                   Tag_Node_Addr,
 915                   New_Reference_To
 916                     (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
 917    end Build_TSD;
 918
 919 end Exp_Atag;