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-2009, 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    procedure Build_Get_Predefined_Prim_Op_Address
 231      (Loc      : Source_Ptr;
 232       Position : Uint;
 233       Tag_Node : in out Node_Id;
 234       New_Node : out Node_Id)
 235    is
 236       Ctrl_Tag : Node_Id;
 237
 238    begin
 239       Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node);
 240
 241       --  Unchecked_Convert_To relocates the controlling tag node and therefore
 242       --  we must update it.
 243
 244       Tag_Node := Expression (Ctrl_Tag);
 245
 246       --  Build code that retrieves the address of the dispatch table
 247       --  containing the predefined Ada primitives:
 248       --
 249       --  Generate:
 250       --    To_Predef_Prims_Table_Ptr
 251       --     (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
 252
 253       New_Node :=
 254         Make_Indexed_Component (Loc,
 255           Prefix =>
 256             Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 257               Make_Explicit_Dereference (Loc,
 258                 Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 259                   Make_Function_Call (Loc,
 260                     Name =>
 261                       Make_Expanded_Name (Loc,
 262                         Chars => Name_Op_Subtract,
 263                         Prefix =>
 264                           New_Reference_To
 265                             (RTU_Entity (System_Storage_Elements), Loc),
 266                         Selector_Name =>
 267                           Make_Identifier (Loc,
 268                             Chars => Name_Op_Subtract)),
 269                     Parameter_Associations => New_List (
 270                       Ctrl_Tag,
 271                       New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
 272                                         Loc)))))),
 273           Expressions =>
 274             New_List (Make_Integer_Literal (Loc, Position)));
 275    end Build_Get_Predefined_Prim_Op_Address;
 276
 277    -------------------------
 278    -- Build_Inherit_Prims --
 279    -------------------------
 280
 281    function Build_Inherit_Prims
 282      (Loc          : Source_Ptr;
 283       Typ          : Entity_Id;
 284       Old_Tag_Node : Node_Id;
 285       New_Tag_Node : Node_Id;
 286       Num_Prims    : Nat) return Node_Id
 287    is
 288    begin
 289       if RTE_Available (RE_DT) then
 290          return
 291            Make_Assignment_Statement (Loc,
 292              Name =>
 293                Make_Slice (Loc,
 294                  Prefix =>
 295                    Make_Selected_Component (Loc,
 296                      Prefix =>
 297                        Build_DT (Loc, New_Tag_Node),
 298                      Selector_Name =>
 299                        New_Reference_To
 300                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 301                  Discrete_Range =>
 302                    Make_Range (Loc,
 303                    Low_Bound  => Make_Integer_Literal (Loc, 1),
 304                    High_Bound => Make_Integer_Literal (Loc, Num_Prims))),
 305
 306              Expression =>
 307                Make_Slice (Loc,
 308                  Prefix =>
 309                    Make_Selected_Component (Loc,
 310                      Prefix =>
 311                        Build_DT (Loc, Old_Tag_Node),
 312                      Selector_Name =>
 313                        New_Reference_To
 314                          (RTE_Record_Component (RE_Prims_Ptr), Loc)),
 315                  Discrete_Range =>
 316                    Make_Range (Loc,
 317                      Low_Bound  => Make_Integer_Literal (Loc, 1),
 318                      High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
 319       else
 320          return
 321            Make_Assignment_Statement (Loc,
 322              Name =>
 323                Make_Slice (Loc,
 324                  Prefix =>
 325                    Unchecked_Convert_To
 326                      (Node (Last_Elmt (Access_Disp_Table (Typ))),
 327                       New_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
 333              Expression =>
 334                Make_Slice (Loc,
 335                  Prefix =>
 336                    Unchecked_Convert_To
 337                      (Node (Last_Elmt (Access_Disp_Table (Typ))),
 338                       Old_Tag_Node),
 339                  Discrete_Range =>
 340                    Make_Range (Loc,
 341                      Low_Bound  => Make_Integer_Literal (Loc, 1),
 342                      High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
 343       end if;
 344    end Build_Inherit_Prims;
 345
 346    -------------------------------
 347    -- Build_Get_Prim_Op_Address --
 348    -------------------------------
 349
 350    procedure Build_Get_Prim_Op_Address
 351      (Loc      : Source_Ptr;
 352       Typ      : Entity_Id;
 353       Position : Uint;
 354       Tag_Node : in out Node_Id;
 355       New_Node : out Node_Id)
 356    is
 357       New_Prefix : Node_Id;
 358
 359    begin
 360       pragma Assert
 361         (Position <= DT_Entry_Count (First_Tag_Component (Typ)));
 362
 363       --  At the end of the Access_Disp_Table list we have the type
 364       --  declaration required to convert the tag into a pointer to
 365       --  the prims_ptr table (see Freeze_Record_Type).
 366
 367       New_Prefix :=
 368         Unchecked_Convert_To
 369           (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node);
 370
 371       --  Unchecked_Convert_To relocates the controlling tag node and therefore
 372       --  we must update it.
 373
 374       Tag_Node := Expression (New_Prefix);
 375
 376       New_Node :=
 377         Make_Indexed_Component (Loc,
 378           Prefix      => New_Prefix,
 379           Expressions => New_List (Make_Integer_Literal (Loc, Position)));
 380    end Build_Get_Prim_Op_Address;
 381
 382    -----------------------------
 383    -- Build_Get_Transportable --
 384    -----------------------------
 385
 386    function Build_Get_Transportable
 387      (Loc      : Source_Ptr;
 388       Tag_Node : Node_Id) return Node_Id
 389    is
 390    begin
 391       return
 392         Make_Selected_Component (Loc,
 393           Prefix => Build_TSD (Loc, Tag_Node),
 394           Selector_Name =>
 395             New_Reference_To
 396               (RTE_Record_Component (RE_Transportable), Loc));
 397    end Build_Get_Transportable;
 398
 399    ------------------------------------
 400    -- Build_Inherit_Predefined_Prims --
 401    ------------------------------------
 402
 403    function Build_Inherit_Predefined_Prims
 404      (Loc          : Source_Ptr;
 405       Old_Tag_Node : Node_Id;
 406       New_Tag_Node : Node_Id) return Node_Id
 407    is
 408    begin
 409       return
 410         Make_Assignment_Statement (Loc,
 411           Name =>
 412             Make_Slice (Loc,
 413               Prefix =>
 414                 Make_Explicit_Dereference (Loc,
 415                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 416                     Make_Explicit_Dereference (Loc,
 417                       Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 418                         New_Tag_Node)))),
 419               Discrete_Range => Make_Range (Loc,
 420                 Make_Integer_Literal (Loc, Uint_1),
 421                 New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),
 422
 423           Expression =>
 424             Make_Slice (Loc,
 425               Prefix =>
 426                 Make_Explicit_Dereference (Loc,
 427                   Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 428                     Make_Explicit_Dereference (Loc,
 429                       Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 430                         Old_Tag_Node)))),
 431               Discrete_Range =>
 432                 Make_Range (Loc,
 433                   Make_Integer_Literal (Loc, 1),
 434                   New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));
 435    end Build_Inherit_Predefined_Prims;
 436
 437    -------------------------
 438    -- Build_Offset_To_Top --
 439    -------------------------
 440
 441    function Build_Offset_To_Top
 442      (Loc       : Source_Ptr;
 443       This_Node : Node_Id) return Node_Id
 444    is
 445       Tag_Node : Node_Id;
 446
 447    begin
 448       Tag_Node :=
 449         Make_Explicit_Dereference (Loc,
 450           Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
 451
 452       return
 453         Make_Explicit_Dereference (Loc,
 454           Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
 455             Make_Function_Call (Loc,
 456               Name =>
 457                 Make_Expanded_Name (Loc,
 458                   Chars => Name_Op_Subtract,
 459                   Prefix => New_Reference_To
 460                              (RTU_Entity (System_Storage_Elements), Loc),
 461                   Selector_Name => Make_Identifier (Loc,
 462                                      Chars => Name_Op_Subtract)),
 463               Parameter_Associations => New_List (
 464                 Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 465                 New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
 466                                   Loc)))));
 467    end Build_Offset_To_Top;
 468
 469    ------------------------------------------
 470    -- Build_Set_Predefined_Prim_Op_Address --
 471    ------------------------------------------
 472
 473    function Build_Set_Predefined_Prim_Op_Address
 474      (Loc          : Source_Ptr;
 475       Tag_Node     : Node_Id;
 476       Position     : Uint;
 477       Address_Node : Node_Id) return Node_Id
 478    is
 479    begin
 480       return
 481          Make_Assignment_Statement (Loc,
 482            Name =>
 483              Make_Indexed_Component (Loc,
 484                Prefix =>
 485                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
 486                    Make_Explicit_Dereference (Loc,
 487                      Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))),
 488                Expressions =>
 489                  New_List (Make_Integer_Literal (Loc, Position))),
 490
 491            Expression => Address_Node);
 492    end Build_Set_Predefined_Prim_Op_Address;
 493
 494    -------------------------------
 495    -- Build_Set_Prim_Op_Address --
 496    -------------------------------
 497
 498    function Build_Set_Prim_Op_Address
 499      (Loc          : Source_Ptr;
 500       Typ          : Entity_Id;
 501       Tag_Node     : Node_Id;
 502       Position     : Uint;
 503       Address_Node : Node_Id) return Node_Id
 504    is
 505       Ctrl_Tag : Node_Id := Tag_Node;
 506       New_Node : Node_Id;
 507
 508    begin
 509       Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node);
 510
 511       return
 512         Make_Assignment_Statement (Loc,
 513           Name       => New_Node,
 514           Expression => Address_Node);
 515    end Build_Set_Prim_Op_Address;
 516
 517    -----------------------------
 518    -- Build_Set_Size_Function --
 519    -----------------------------
 520
 521    function Build_Set_Size_Function
 522      (Loc       : Source_Ptr;
 523       Tag_Node  : Node_Id;
 524       Size_Func : Entity_Id) return Node_Id is
 525    begin
 526       pragma Assert (Chars (Size_Func) = Name_uSize
 527         and then RTE_Record_Component_Available (RE_Size_Func));
 528       return
 529         Make_Assignment_Statement (Loc,
 530           Name =>
 531             Make_Selected_Component (Loc,
 532               Prefix => Build_TSD (Loc, Tag_Node),
 533               Selector_Name =>
 534                 New_Reference_To
 535                   (RTE_Record_Component (RE_Size_Func), Loc)),
 536           Expression =>
 537             Unchecked_Convert_To (RTE (RE_Size_Ptr),
 538               Make_Attribute_Reference (Loc,
 539                 Prefix => New_Reference_To (Size_Func, Loc),
 540                 Attribute_Name => Name_Unrestricted_Access)));
 541    end Build_Set_Size_Function;
 542
 543    ------------------------------------
 544    -- Build_Set_Static_Offset_To_Top --
 545    ------------------------------------
 546
 547    function Build_Set_Static_Offset_To_Top
 548      (Loc          : Source_Ptr;
 549       Iface_Tag    : Node_Id;
 550       Offset_Value : Node_Id) return Node_Id is
 551    begin
 552       return
 553         Make_Assignment_Statement (Loc,
 554           Make_Explicit_Dereference (Loc,
 555             Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr),
 556               Make_Function_Call (Loc,
 557                 Name =>
 558                   Make_Expanded_Name (Loc,
 559                     Chars => Name_Op_Subtract,
 560                     Prefix => New_Reference_To
 561                                (RTU_Entity (System_Storage_Elements), Loc),
 562                     Selector_Name => Make_Identifier (Loc,
 563                                        Chars => Name_Op_Subtract)),
 564                 Parameter_Associations => New_List (
 565                   Unchecked_Convert_To (RTE (RE_Address), Iface_Tag),
 566                   New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
 567                                     Loc))))),
 568           Offset_Value);
 569    end Build_Set_Static_Offset_To_Top;
 570
 571    ---------------
 572    -- Build_TSD --
 573    ---------------
 574
 575    function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
 576    begin
 577       return
 578         Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
 579           Make_Explicit_Dereference (Loc,
 580             Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
 581               Make_Function_Call (Loc,
 582                 Name =>
 583                   Make_Expanded_Name (Loc,
 584                     Chars => Name_Op_Subtract,
 585                     Prefix =>
 586                       New_Reference_To
 587                         (RTU_Entity (System_Storage_Elements), Loc),
 588                     Selector_Name =>
 589                       Make_Identifier (Loc,
 590                         Chars => Name_Op_Subtract)),
 591
 592                 Parameter_Associations => New_List (
 593                   Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
 594                     New_Reference_To
 595                       (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
 596    end Build_TSD;
 597
 598 end Exp_Atag;