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