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