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