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