gcc/ada/exp_atag.adb

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