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-2008, 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 Einfo;    use Einfo;
  27 with Elists;   use Elists;
  28 with Exp_Util; use Exp_Util;
  29 with Namet;    use Namet;
  30 with Nlists;   use Nlists;
  31 with Nmake;    use Nmake;
  32 with Rtsfind;  use Rtsfind;
  33 with Sinfo;    use Sinfo;
  34 with Sem_Util; use Sem_Util;
  35 with Stand;    use Stand;
  36 with Snames;   use Snames;
  37 with Tbuild;   use Tbuild;
  38
  39 package body Exp_Atag is
  40
  41    -----------------------
  42    -- Local Subprograms --
  43    -----------------------
  44
  45    function Build_DT
  46      (Loc      : Source_Ptr;
  47       Tag_Node : Node_Id) return Node_Id;
  48    --  Build code that displaces the Tag to reference the base of the wrapper
  49    --  record
  50    --
  51    --  Generates:
  52    --    To_Dispatch_Table_Ptr
  53    --      (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
  54
  55    function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id;
  56    --  Build code that retrieves the address of the record containing the Type
  57    --  Specific Data generated by GNAT.
  58    --
  59    --  Generate: To_Type_Specific_Data_Ptr
  60    --              (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
  61
  62    ------------------------------------------------
  63    -- Build_Common_Dispatching_Select_Statements --
  64    ------------------------------------------------
  65
  66    procedure Build_Common_Dispatching_Select_Statements
  67      (Loc    : Source_Ptr;
  68       DT_Ptr : Entity_Id;
  69       Stmts  : List_Id)
  70    is
  71    begin
  72       --  Generate:
  73       --    C := get_prim_op_kind (tag! (<type>VP), S);
  74
  75       --  where C is the out parameter capturing the call kind and S is the
  76       --  dispatch table slot number.
  77
  78       Append_To (Stmts,
  79         Make_Assignment_Statement (Loc,
  80           Name =>
  81             Make_Identifier (Loc, Name_uC),
  82           Expression =>
  83             Make_Function_Call (Loc,
  84               Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),
  85               Parameter_Associations => New_List (
  86                 Unchecked_Convert_To (RTE (RE_Tag),
  87                   New_Reference_To (DT_Ptr, Loc)),
  88                 Make_Identifier (Loc, Name_uS)))));
  89
  90       --  Generate:
  91
  92       --    if C = POK_Procedure
  93       --      or else C = POK_Protected_Procedure
  94       --      or else C = POK_Task_Procedure;
  95       --    then
  96       --       F := True;
  97       --       return;
  98
  99       --  where F is the out parameter capturing the status of a potential
 100       --  entry call.
 101
 102       Append_To (Stmts,
 103         Make_If_Statement (Loc,
 104
 105           Condition =>
 106             Make_Or_Else (Loc,
 107               Left_Opnd =>
 108                 Make_Op_Eq (Loc,
 109                   Left_Opnd =>
 110                     Make_Identifier (Loc, Name_uC),
 111                   Right_Opnd =>
 112                     New_Reference_To (RTE (RE_POK_Procedure), Loc)),
 113               Right_Opnd =>
 114                 Make_Or_Else (Loc,
 115                   Left_Opnd =>
 116                     Make_Op_Eq (Loc,
 117                       Left_Opnd =>
 118                         Make_Identifier (Loc, Name_uC),
 119                       Right_Opnd =>
 120                         New_Reference_To (RTE (
 121                           RE_POK_Protected_Procedure), Loc)),
 122                   Right_Opnd =>
 123                     Make_Op_Eq (Loc,
 124                       Left_Opnd =>
 125                         Make_Identifier (Loc, Name_uC),
 126                       Right_Opnd =>
 127                         New_Reference_To (RTE (
 128                           RE_POK_Task_Procedure), Loc)))),
 129
 130           Then_Statements =>
 131             New_List (
 132               Make_Assignment_Statement (Loc,
 133                 Name       => Make_Identifier (Loc, Name_uF),
 134                 Expression => New_Reference_To (Standard_True, Loc)),
 135               Make_Simple_Return_Statement (Loc))));
 136    end Build_Common_Dispatching_Select_Statements;
 137
 138    -------------------------
 139    -- Build_CW_Membership --
 140    -------------------------
 141
 142    function Build_CW_Membership
 143      (Loc          : Source_Ptr;
 144       Obj_Tag_Node : Node_Id;
 145       Typ_Tag_Node : Node_Id) return Node_Id
 146    is
 147       function Build_Pos return Node_Id;
 148       --  Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
 149
 150       function Build_Pos return Node_Id is
 151       begin
 152          return
 153             Make_Op_Subtract (Loc,
 154               Left_Opnd =>
 155                 Make_Selected_Component (Loc,
 156                   Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)),
 157                   Selector_Name =>
 158                     New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)),
 159
 160               Right_Opnd =>
 161                 Make_Selected_Component (Loc,
 162                   Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)),
 163                   Selector_Name =>
 164                     New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)));
 165       end Build_Pos;
 166
 167    --  Start of processing for Build_CW_Membership
 168
 169    begin
 170       return
 171         Make_And_Then (Loc,
 172           Left_Opnd =>
 173             Make_Op_Ge (Loc,
 174               Left_Opnd  => Build_Pos,
 175               Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
 176
 177           Right_Opnd =>
 178             Make_Op_Eq (Loc,
 179               Left_Opnd =>
 180                 Make_Indexed_Component (Loc,
 181                   Prefix =>
 182                     Make_Selected_Component (Loc,
 183                       Prefix => Build_TSD (Loc, Obj_Tag_Node),
 184                       Selector_Name =>
 185                         New_Reference_To
 186                           (RTE_Record_Component (RE_Tags_Table), Loc)),
 187                   Expressions =>
 188                     New_List (Build_Pos)),
 189
 190               Right_Opnd => Typ_Tag_Node));
 191    end Build_CW_Membership;
 192
 193    --------------
 194    -- Build_DT --
 195    --------------
 196
 197    function Build_DT
 198      (Loc      : Source_Ptr;
 199       Tag_Node : Node_Id) return Node_Id is
 200    begin
 201       return
 202         Make_Function_Call (Loc,
 203           Name => New_Reference_To (RTE (RE_DT), Loc),
 204           Parameter_Associations => New_List (
 205             Unchecked_Convert_To (RTE (RE_Tag), Tag_Node)));
 206    end Build_DT;
 207
 208    ----------------------------
 209    -- Build_Get_Access_Level --
 210    ----------------------------
 211
 212    function Build_Get_Access_Level
 213      (Loc      : Source_Ptr;
 214       Tag_Node : Node_Id) return Node_Id
 215    is
 216    begin
 217       return
 218         Make_Selected_Component (Loc,
 219           Prefix => Build_TSD (Loc, Tag_Node),
 220           Selector_Name =>
 221             New_Reference_To
 222               (RTE_Record_Component (RE_Access_Level), Loc));
 223    end Build_Get_Access_Level;
 224
 225    ------------------------------------------
 226    -- Build_Get_Predefined_Prim_Op_Address --
 227    ------------------------------------------
 228
 229    function Build_Get_Predefined_Prim_Op_Address
 230      (Loc      : Source_Ptr;
 231       Tag_Node : Node_Id;
 232       Position : Uint) return Node_Id
 233    is
 234    begin
 235       --  Build code that retrieves the address of the dispatch table
 236       --  containing the predefined Ada primitives:
 237       --
 238       --  Generate:
 239       --    To_Predef_Prims_Table_Ptr
 240       --     (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
 241
 242       return
 243         Make_Indexed_Component (Loc,
 244           Prefix =>
 245             Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 246               Make_Explicit_Dereference (Loc,
 247                 Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 248                   Make_Function_Call (Loc,
 249                     Name =>
 250                       Make_Expanded_Name (Loc,
 251                         Chars => Name_Op_Subtract,
 252                         Prefix =>
 253                           New_Reference_To
 254                             (RTU_Entity (System_Storage_Elements), Loc),
 255                         Selector_Name =>
 256                           Make_Identifier (Loc,
 257                             Chars => Name_Op_Subtract)),
 258                     Parameter_Associations => New_List (
 259                       Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 260                       New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
 261                                         Loc)))))),
 262           Expressions =>
 263             New_List (Make_Integer_Literal (Loc, Position)));
 264    end Build_Get_Predefined_Prim_Op_Address;
 265
 266    -------------------------
 267    -- Build_Inherit_Prims --
 268    -------------------------
 269
 270    function Build_Inherit_Prims
 271      (Loc          : Source_Ptr;
 272       Typ          : Entity_Id;
 273       Old_Tag_Node : Node_Id;
 274       New_Tag_Node : Node_Id;
 275       Num_Prims    : Nat) return Node_Id
 276    is
 277    begin
 278       if RTE_Available (RE_DT) then
 279          return
 280            Make_Assignment_Statement (Loc,
 281              Name =>
 282                Make_Slice (Loc,
 283                  Prefix =>
 284                    Make_Selected_Component (Loc,
 285                      Prefix =>
 286                        Build_DT (Loc, New_Tag_Node),
 287                      Selector_Name =>
 288                        New_Reference_To
 289                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 290                  Discrete_Range =>
 291                    Make_Range (Loc,
 292                    Low_Bound  => Make_Integer_Literal (Loc, 1),
 293                    High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
 294
 295              Expression =>
 296                Make_Slice (Loc,
 297                  Prefix =>
 298                    Make_Selected_Component (Loc,
 299                      Prefix =>
 300                        Build_DT (Loc, Old_Tag_Node),
 301                      Selector_Name =>
 302                        New_Reference_To
 303                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 304                  Discrete_Range =>
 305                    Make_Range (Loc,
 306                      Low_Bound  => Make_Integer_Literal (Loc, 1),
 307                      High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
 308       else
 309          return
 310            Make_Assignment_Statement (Loc,
 311              Name =>
 312                Make_Slice (Loc,
 313                  Prefix =>
 314                    Unchecked_Convert_To
 315                      (Node (Last_Elmt (Access_Disp_Table (Typ))),
 316                       New_Tag_Node),
 317                  Discrete_Range =>
 318                    Make_Range (Loc,
 319                    Low_Bound  => Make_Integer_Literal (Loc, 1),
 320                    High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
 321
 322              Expression =>
 323                Make_Slice (Loc,
 324                  Prefix =>
 325                    Unchecked_Convert_To
 326                      (Node (Last_Elmt (Access_Disp_Table (Typ))),
 327                       Old_Tag_Node),
 328                  Discrete_Range =>
 329                    Make_Range (Loc,
 330                      Low_Bound  => Make_Integer_Literal (Loc, 1),
 331                      High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
 332       end if;
 333    end Build_Inherit_Prims;
 334
 335    -------------------------------
 336    -- Build_Get_Prim_Op_Address --
 337    -------------------------------
 338
 339    function Build_Get_Prim_Op_Address
 340      (Loc      : Source_Ptr;
 341       Typ      : Entity_Id;
 342       Tag_Node : Node_Id;
 343       Position : Uint) return Node_Id
 344    is
 345    begin
 346       pragma Assert
 347         (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
 348
 349       --  At the end of the Access_Disp_Table list we have the type
 350       --  declaration required to convert the tag into a pointer to
 351       --  the prims_ptr table (see Freeze_Record_Type).
 352
 353       return
 354         Make_Indexed_Component (Loc,
 355           Prefix =>
 356             Unchecked_Convert_To
 357               (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node),
 358           Expressions => New_List (Make_Integer_Literal (Loc, Position)));
 359    end Build_Get_Prim_Op_Address;
 360
 361    -----------------------------
 362    -- Build_Get_Transportable --
 363    -----------------------------
 364
 365    function Build_Get_Transportable
 366      (Loc      : Source_Ptr;
 367       Tag_Node : Node_Id) return Node_Id
 368    is
 369    begin
 370       return
 371         Make_Selected_Component (Loc,
 372           Prefix => Build_TSD (Loc, Tag_Node),
 373           Selector_Name =>
 374             New_Reference_To
 375               (RTE_Record_Component (RE_Transportable), Loc));
 376    end Build_Get_Transportable;
 377
 378    ------------------------------------
 379    -- Build_Inherit_Predefined_Prims --
 380    ------------------------------------
 381
 382    function Build_Inherit_Predefined_Prims
 383      (Loc          : Source_Ptr;
 384       Old_Tag_Node : Node_Id;
 385       New_Tag_Node : Node_Id) return Node_Id
 386    is
 387    begin
 388       return
 389         Make_Assignment_Statement (Loc,
 390           Name =>
 391             Make_Slice (Loc,
 392               Prefix =>
 393                 Make_Explicit_Dereference (Loc,
 394                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 395                     Make_Explicit_Dereference (Loc,
 396                       Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 397                         New_Tag_Node)))),
 398               Discrete_Range => Make_Range (Loc,
 399                 Make_Integer_Literal (Loc, Uint_1),
 400                 New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
 401
 402           Expression =>
 403             Make_Slice (Loc,
 404               Prefix =>
 405                 Make_Explicit_Dereference (Loc,
 406                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 407                     Make_Explicit_Dereference (Loc,
 408                       Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 409                         Old_Tag_Node)))),
 410               Discrete_Range =>
 411                 Make_Range (Loc,
 412                   Make_Integer_Literal (Loc, 1),
 413                   New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
 414    end Build_Inherit_Predefined_Prims;
 415
 416    -------------------------
 417    -- Build_Offset_To_Top --
 418    -------------------------
 419
 420    function Build_Offset_To_Top
 421      (Loc       : Source_Ptr;
 422       This_Node : Node_Id) return Node_Id
 423    is
 424       Tag_Node : Node_Id;
 425
 426    begin
 427       Tag_Node :=
 428         Make_Explicit_Dereference (Loc,
 429           Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
 430
 431       return
 432         Make_Explicit_Dereference (Loc,
 433           Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
 434             Make_Function_Call (Loc,
 435               Name =>
 436                 Make_Expanded_Name (Loc,
 437                   Chars => Name_Op_Subtract,
 438                   Prefix => New_Reference_To
 439                              (RTU_Entity (System_Storage_Elements), Loc),
 440                   Selector_Name => Make_Identifier (Loc,
 441                                      Chars => Name_Op_Subtract)),
 442               Parameter_Associations => New_List (
 443                 Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 444                 New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
 445                                   Loc)))));
 446    end Build_Offset_To_Top;
 447
 448    ------------------------------------------
 449    -- Build_Set_Predefined_Prim_Op_Address --
 450    ------------------------------------------
 451
 452    function Build_Set_Predefined_Prim_Op_Address
 453      (Loc          : Source_Ptr;
 454       Tag_Node     : Node_Id;
 455       Position     : Uint;
 456       Address_Node : Node_Id) return Node_Id
 457    is
 458    begin
 459       return
 460          Make_Assignment_Statement (Loc,
 461            Name =>
 462              Make_Indexed_Component (Loc,
 463                Prefix =>
 464                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 465                    Make_Explicit_Dereference (Loc,
 466                      Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
 467                Expressions =>
 468                  New_List (Make_Integer_Literal (Loc, Position))),
 469
 470            Expression => Address_Node);
 471    end Build_Set_Predefined_Prim_Op_Address;
 472
 473    -------------------------------
 474    -- Build_Set_Prim_Op_Address --
 475    -------------------------------
 476
 477    function Build_Set_Prim_Op_Address
 478      (Loc          : Source_Ptr;
 479       Typ          : Entity_Id;
 480       Tag_Node     : Node_Id;
 481       Position     : Uint;
 482       Address_Node : Node_Id) return Node_Id
 483    is
 484    begin
 485       return
 486         Make_Assignment_Statement (Loc,
 487           Name       => Build_Get_Prim_Op_Address
 488                           (Loc, Typ, Tag_Node, Position),
 489           Expression => Address_Node);
 490    end Build_Set_Prim_Op_Address;
 491
 492    -----------------------------
 493    -- Build_Set_Size_Function --
 494    -----------------------------
 495
 496    function Build_Set_Size_Function
 497      (Loc       : Source_Ptr;
 498       Tag_Node  : Node_Id;
 499       Size_Func : Entity_Id) return Node_Id is
 500    begin
 501       pragma Assert (Chars (Size_Func) = Name_uSize
 502         and then RTE_Record_Component_Available (RE_Size_Func));
 503       return
 504         Make_Assignment_Statement (Loc,
 505           Name =>
 506             Make_Selected_Component (Loc,
 507               Prefix => Build_TSD (Loc, Tag_Node),
 508               Selector_Name =>
 509                 New_Reference_To
 510                   (RTE_Record_Component (RE_Size_Func), Loc)),
 511           Expression =>
 512             Unchecked_Convert_To (RTE (RE_Size_Ptr),
 513               Make_Attribute_Reference (Loc,
 514                 Prefix => New_Reference_To (Size_Func, Loc),
 515                 Attribute_Name => Name_Unrestricted_Access)));
 516    end Build_Set_Size_Function;
 517
 518    ------------------------------------
 519    -- Build_Set_Static_Offset_To_Top --
 520    ------------------------------------
 521
 522    function Build_Set_Static_Offset_To_Top
 523      (Loc          : Source_Ptr;
 524       Iface_Tag    : Node_Id;
 525       Offset_Value : Node_Id) return Node_Id is
 526    begin
 527       return
 528         Make_Assignment_Statement (Loc,
 529           Make_Explicit_Dereference (Loc,
 530             Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
 531               Make_Function_Call (Loc,
 532                 Name =>
 533                   Make_Expanded_Name (Loc,
 534                     Chars => Name_Op_Subtract,
 535                     Prefix => New_Reference_To
 536                                (RTU_Entity (System_Storage_Elements), Loc),
 537                     Selector_Name => Make_Identifier (Loc,
 538                                        Chars => Name_Op_Subtract)),
 539                 Parameter_Associations => New_List (
 540                   Unchecked_Convert_To (RTE (RE_Address), Iface_Tag),
 541                   New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
 542                                     Loc))))),
 543           Offset_Value);
 544    end Build_Set_Static_Offset_To_Top;
 545
 546    ---------------
 547    -- Build_TSD --
 548    ---------------
 549
 550    function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
 551    begin
 552       return
 553         Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
 554           Make_Explicit_Dereference (Loc,
 555             Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 556               Make_Function_Call (Loc,
 557                 Name =>
 558                   Make_Expanded_Name (Loc,
 559                     Chars => Name_Op_Subtract,
 560                     Prefix =>
 561                       New_Reference_To
 562                         (RTU_Entity (System_Storage_Elements), Loc),
 563                     Selector_Name =>
 564                       Make_Identifier (Loc,
 565                         Chars => Name_Op_Subtract)),
 566
 567                 Parameter_Associations => New_List (
 568                   Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 569                     New_Reference_To
 570                       (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
 571    end Build_TSD;
 572
 573 end Exp_Atag;