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