gcc/ada/exp_atag.adb

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